perm filename PCPS04.PAS[S1,ALS] blob
sn#410608 filedate 1979-01-10 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00045 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00006 00002 (* *** V E R S I O N I N F O R M A T I O N P A G E *** *)
C00007 00003 (*PROGRAM HEADER PAGE*)
C00011 00004 (*********************************************************
C00026 00005 CONST DISPLIMIT = 20 MAXLEVEL = 10" MAXADDR = 16777215"(*XSL10*)
C00030 00006 TYPE (*DESCRIBING:*)
C00038 00007 VAR
C00044 00008 (*EXPRESSION COMPILATION:*)
C00047 00009 (** ERREXIT PRINTERROR FILL_BUFFER LISTLINE SKIP_E_DIRECTORY ENDOFLINE ERROR **)
C00053 00010 (** INSYMBOL SKIPBLNK NEXTCH OPTIONS **)
C00078 00011 (** ENTERID SEARCHSECTION SEARCHID GETBOUNDS **)
C00084 00012 (** PRINTTABLES MARKER MARKCTP MARKSTP MARKCTP FOLLOWCTP FOLLOWSTP **)
C00090 00013 (** FOLLOWCTP GENLABEL PRNTSYMBL PRNTVAR PRNTTYPE PRNTVAR **)
C00100 00014 (** SET_IN BUILD_SET **)
C00102 00015 (** BLOCK SKIP ALIGN CONSTANT **)
C00108 00016 (** COMPTYPES STRING **)
C00113 00017 (** TYP SIMPLETYPE **)
C00120 00018 (** FIELDLIST **)
C00128 00019 BEGIN (*TYP*)
C00137 00020 (** LABELDECLARATION CONSTDECLARATION TYPEDECLARATION **)
C00143 00021 (** VARDECLARATION **)
C00147 00022 (** PROCDECLARATION PARAMETERLIST **)
C00158 00023 BEGIN (*PROCDECLARATION*)
C00167 00024 (** PROCTYPE BODY PUTIC FLDW GETTYPE **)
C00172 00025 (** GEN0 GEN1 GEN2 PRINT_SET_OPND **)
C00179 00026 (** GEN3 LOAD STORE **)
C00183 00027 (** LOADADDRESS GENFJP GENUJPFJP GENCUPENT MKNAME GENDEF CHKBNDS PUTLABEL CTRGEN CTREMIT **)
C00192 00028 (** STATEMENT EXPRESSION SELECTOR **)
C00201 00029 (** CALL VARIABLE RWSETUP GETPUTRESETREWRITE READ1 **)
C00207 00030 (** WRITE1 PACK1 UNPACK1 **)
C00214 00031 (** NEW1 MARK1 RELEASE1 TRAPEXIT **)
C00219 00032 (** ABS1 SQR1 TRUNC1 ODD1 ORD1 CHR1 PREDSUCCTIM EOFEOLN MATH **)
C00230 00033 (** CALLNONSTANDARD **)
C00242 00034 (** EXPRESSION SIMPLEEXPRESSION TERM FACTOR **)
C00253 00035 BEGIN (*SIMPLEEXPRESSION*)
C00260 00036 (** ASSIGNMENT **)
C00268 00037 (** GOTOSTATEMENT COMPOUNDSTATEMENT IFSTATEMENT **)
C00274 00038 (** CASESTATEMENT REPEATSTATEMENT WHILESTATEMENT **)
C00284 00039 (** FORSTATEMENT WITHSTATEMENT **)
C00294 00040 BEGIN (*BODY*)
C00301 00041 (** MKNAME PROGRAMME STDNAMES ENTERSTDTYPES **)
C00315 00042 (** ENTSTDNAMES ENTERUNDECL **)
C00323 00043 (** INITSCALARS INITSETS INITTABLES RESWORDS SYMBOLS RATORS PROCMNEMONICS **)
C00334 00044 (** INSTRMNEMONICS **)
C00337 00045 BEGIN (*PASCALCOMPILER*)
C00340 ENDMK
C⊗;
(* *** V E R S I O N I N F O R M A T I O N P A G E *** *)
(* This version modified from copy of PCPE02.PAS[S1,EJG] made 11/11/78 14:08 *)
(* This version modified from copy of PCPG02.PAS[1,PEG] made 11/11/78 11:35 *)
(* The full directory information for that version is:
PCPG02 PAS 1PEG 41.8 06-Nov-78 0947 205 1PEG E 11-Nov-78 09-Nov-78 T33
An unmodified copy of that version is kept in PCPG02.PAS[S1,EJG] *)
(*PROGRAM HEADER PAGE*)
(*PAS10 OPTIONS*) (*$D+,R32,X6,F1*) (*X10S1*)
(* DEFAULT
L+ OBJECT LISTING -
T+ RUNTIME CHECK +
D+ DEBUG AND POSTMORTEM DUMP -
E+ EXTERNAL CALLS TO LEVEL 1 PROCEDURES ALLOWED -
U+ 72 COLUMN FORMAT -
Sn MAX INSTRUCTIONS PER STATEMENT 1000
Rn SIZE OF LOW-SEGMENT (SEE PAS10 MANUAL)
I+ FORTRAN I/O IN EXTERNAL FORTRAN SUBROUTINES -
Xn HIGHEST REGISTER FOR PARAMETERS 6
Fn FILE OPTION 1
*)
(*SLAC PCPASC OPTIONS*) (* D+,M-,B+*)
(* DEFAULT
L+ LIST SOURCE PROGRAM +
T+ PRINT SYMBOL TABLES (FOR POST-PROCESSOR) -
D+ RUNTIME CHECKING OF POINTER, INDEX, SUBRANGE VALUES -
E+ FILE IS IN EBCDIC CHARACTER SET -
U+ GET STATISTICS?? 2ND PARAMETER TO PCODE BGN INSTR. -
S+ SAVE GPR'S ON PROCEDURE/FUNCTION ENTRY +
X+ USE ACTUAL PROCEDURE NAMES FOR EXTERNAL REFERENCES -
X- GENERATE UNIQUE 8-CHAR NAMES FOR EXTERNAL REFERENCES
F+ SAVE FPR'S ON PROCEDURE/FUNCTION ENTRY +
C+ EMIT PCODE +
M+ 72 COLUMN FORMAT +
A+ GENERATE 370 OBJECT MODULE -
A- GENERATE 370 ASSEMBLY MODULE
B+ BOUNDS CHECKING, BUT ALLOW 'BIG' CHARACTERS -
K+ ENABLE STATEMENT EXECUTION COUNTING -
V+ ?? 3RD PCODE BGN INSTRUCTION PARAMETER -
P+ DOUBLE-WORD BOUNDARY ALIGNMENT -
*)
(*S1 PCPASC OPTION DIFFERENCES*) (* A+,B+,M120*) (*X10S1*)
(* DEFAULT
A+ GENERATE S1 ASSEMBLY MODULE -
A- GENERATE S1 OBJECT MODULE
Mn MARGIN LENGTH 80
N+ LAST 8 COLS. (MARGIN - 8 TO MARGIN) -
INTERPRETED AS SEQUENCE NUMBERS
*)
(*XSL10 MARKS CHANGES FOR TRANSPORTING FROM SLAC TO PDP10*)
(*TRANSLATE "@" TO "↑" XSL10*)
(*SETCH MARKS CHANGES MADE TO ENLARGE SET SIZE*)
(*X10S1 MARKS CHANGES FOR TRANSPORTING FROM PDP10 TO S-1*)
PROGRAM PCPASC(INPUT*,OUTPUT,PRR); (*XSL10-- '*' AFTER INPUT FILES*) (*X10S1*)
(*PROGRAM PCPASC(INPUT,OUTPUT,PRR);*) (*X10S1*)
(*********************************************************
* *
* *
* STEP-WISE DEVELOPMENT OF A PASCAL COMPILER *
* ****************************************** *
* *
* *
* STEP 5: SYNTAX ANALYSIS INCLUDING ERROR *
* HANDLING; CHECKS BASED ON DECLARA- *
* 10/7/73 TIONS; ADDRESS AND CODE GENERATION *
* FOR A HYPOTHETICAL STACK COMPUTER *
* *
* *
* AUTHOR: URS AMMANN *
* FACHGRUPPE COMPUTERWISSENSCHAFTEN *
* EIDG. TECHNISCHE HOCHSCHULE *
* CH-8006 ZUERICH *
* *
* *
* *
* MODIFICATION OF STEP 5 OF PASCAL COMPILER *
* ***************************************** *
* *
* THE COMPILER IS NOW WRITTEN IN A SUBSET OF *
* STANDARD PASCAL - AS DEFINED IN THE NEW *
* MANUAL BY K. JENSEN AND N. WIRTH - AND IT *
* PROCESSES EXACTLY THIS SUBSET. *
* *
* AUTHOR OF CHANGES: KESAV NORI *
* COMPUTER GROUP *
* T.I.F.R. *
* HOMI BHABHA ROAD *
* BOMBAY - 400005 *
* INDIA *
* *
* THESE CHANGES WERE COMPLETED AT ETH, ZURICH *
* ON 20/5/74. *
* *
* *
* *
* +++++++++++++++++++++++++++++++++++++++++++ *
* *
* *
* *
* THE COMPILER IS NOW CHANGED TO: *
* ******************************* *
* *
* *
* -PRODUCE THE INTERMEDIATE CODE IN AN *
* ASSEMBLER READABLE FORM (NAMELY THE *
* 370, ASSEMBLER_H), 15-NOV-75. *
* *
* -PRESERVE PROCEDURE NAMES AND THEIR *
* STATIC LEVELS AT THE OBJECT LEVEL, THUS *
* ALLOWING A SET OF 'DISPLAY' REGISTERS TO *
* BE USED IN ACCESSING NON_LOCAL, NON_GLOBAL *
* VARIABLES (INSTEAD OF GOING THROUGH A *
* CHAIN OF POINTERS), 10-DEC-75. *
* *
* -INCLUDE THE TYPE OF THE OPERANDS IN THE *
* P_INSTRUCTIONS AS FOLLOWS: *
* *
* A : ADDRESS (POINTER) OPERAND *
* B : BOOLEAN " *
* C : CHARACTER " *
* I : INTEGER " *
* R : REAL " *
* S : SET " *
* *
* THE P_INSTRUCTION NOW LOOKS LIKE: *
* (LAB) OPCODE (TYPE),(OPERANDS) *
* A NEW PROCEDURE 'EXIT(RC: INTEGER)' IS *
* ADDED TO THE SET OF STANDARD PROCEDURES *
* TO FACILITATE TERMINATING A PROGRAM AT *
* ANY POINT AND RETURNING A 'RETURN CODE' *
* TO THE OPERATING SYSTEM, 26-JAN-76. *
* *
* -TREAT THE INPUT AS A TEXT FILE WITH *
* LINES (RECORDS) OF 80 CHARACTER EACH, *
* THIS ALLOWS A MORE EFFICIENT STRING *
* ORIENTED INPUT, 20-MAR-76. *
* *
* -ALLOCATE AND PROPERLY ALIGN VARIABLES ON *
* THE BASIS OF THEIR TYPES, I.E. *
* *
* TYPE SIZE ALIGNED ON *
* *
* B,C 1-BYTE 1-BYTE *
* A,I 4-BYTES 4-BYTE *
* S 8-BYTES 4-BYTE *
* R 8-BYTES 8-BYTE *
* *
* DYNAMIC STORAGE HOWEVER IS ALWAYS ALLOC- *
* CATED ON 8-BYTE BOUNDARIES TO AVOID RUN- *
* TIME CHECKING OVERHEAD, 25-APR-76. *
* *
* -'READ' OF 'STRING' VARIABLES (I.E. ARRAY *
* OF CHAR) IS NOW IMPLEMENTED AND IT IS TO *
* COMPLEMENT THE SIMILAR 'WRITE' FUNCTION. *
* ALSO THE STANDARD PROCEDURE: *
* TRAP(I: INTEGER; VAR V: [ANY TYPE] ); *
* IS ADDED TO THE SET OF STANDARD PROCEDURES *
* TO FACILITATE COMMUNICATION WITH THE OUT- *
* SIDE WORLD, 10-SEP-76. *
* *
* -RELEVENT INFORMATION ON/ABOUT PROCEDURES *
* ARE NOW SENT TO 'QRR' FILE. THIS INCLUDES *
* SUCH INFORMATION AS THE SIZE OF THE PROCE- *
* DURE AS WELL AS ITS DATA AREA, LIST OF THE *
* PROCEDURES CALLED AND THE # OF CALLS, THE *
* LEVEL OF THE HIGHEST_LEVEL PROCEDURE CALLED *
* ETC. THIS INFORMATION IS MAINLY INTENDED *
* FOR INTER_PROCEDURAL ANALYSIS, BUT IT IS *
* ALSO USEFUL FOR MORE EFFICIENT PROCEDURE *
* ENTRY/EXIT CODE, 22-MAR-77. *
* *
* -TYPES "TEXT" (FILE OF CHAR) AND "ALFA" *
* (PACKED ARRAY [1..10] OF CHAR) ARE NOW *
* ADDED TO THE SET OF PREDEFINED TYPES, *
* 20-MAY-78. *
* *
* -I/O RELATED STANDARD PROCEDURES ARE NOW *
* MODIFIED TO CONFORM TO THE PASCAL 6000 *
* ABBREVIATIONS. EXPRESSIONS SUCH AS *
* "EOF(INPUT)" "EOF()" AND "EOF" ARE NOW *
* EQUIVALENT, 20-MAY-78. *
* *
* -REAL VALUES MAY BE PRINTED IN *
* SCIENTIFIC NOTATION OR THE SO CALLED *
* F_FORMAT DEPENDING ON THE FIELD *
* SPECIFICATION IN THE 'WRITE' / 'WRITELN' *
* STATEMENT. A SIMPLE FIELD SPECIFIER OF *
* THE FORM "R : FLDW" RESULTS IN E_FORMAT *
* WHILE "R : FLDW:DFLD" GENERATES AN *
* F_FORMAT OUTPUT, 20-MAY-78. *
* *
* -'EXTERNAL' AND 'FORTRAN' PROCEDURES / *
* FUNCTIONS ARE NOW SUPPORTED. IN ORDER *
* TO MAKE THE EXTERNAL (CSECT) AND *
* INTERNAL NAMES IDENTICAL, THE NEW 'X' *
* OPTION SWITCH IS INTRODUCED. IF *
* PROCEDURE / FUNCTION NAMES IN A PROGRAM *
* ARE NOT DISTINCT WITHIN THE FIRST 8 *
* CHARACTERS, (A PROBLEM WHICH WILL *
* CONFUSE THE "LOADER") THE 'X-' OPTION *
* WILL GENERATE UNIQUE EXTERNAL NAMES FOR *
* ALL PROCEDURES IN THE PROGRAM, AND THESE *
* NAMES SHOULD BE USED FOR THE *
* CORRESPONDING EXTERNAL/FORTRAN ROUTINES, *
* OTHERWISE ONE SHOULD USE THE 'X+' OPTION *
* TO BE ABLE TO USE THE EXTERNAL NAMES WITH NO *
* CHANGE, 2-JUNE-78. *
* *
* *
* THE ABOVE CHANGES (INCLUDING ADDITIONS AND/OR *
* DELETIONS) HAVE BEEN TAGGED BY A '#' TAG AT *
* THE BEGINNING OR THE END OF AFFECTED LINES. *
* *
* *
* *
* S. HAZEGHI *
* *
* COMPUTATION RESEARCH GROUP *
* S.L.A.C. *
* *
* *
* *
*********************************************************)
CONST DISPLIMIT = 20; MAXLEVEL = 10;" MAXADDR = 16777215;"(*XSL10*)
MAXADDR = 1073741823; (*XSL10*)
INTSIZE = 4; "REALSIZE = 8;" REALSIZE = 4; (*XSL10*)
CHARDIF = 40B; (*CHARDIF*) (*X10S1*)
(*CHARDIF = 0; *) (*CHARDIF*) (*X10S1*)
" CHARSIZE = 1; BOOLSIZE = 1; SETSIZE = 16 ; PTRSIZE = 4; (*SET_CH*)"
"EJG" CHARSIZE = 1; BOOLSIZE = 1; SETSIZE = 8 ; PTRSIZE = 4; (*SET_CH*)
"S0" " LCAFTMST = 80; FPSAVEAREA = 32 ; RUNCHKAREA = 96 ; "
"S0" " DSPLYAREA = 72 ; FNCRSLT = 72 ; "
"S0" " (* SAVE AREAS, FUNCTION RETURN VALUE SPACE, DISPLAY AREA, ETC. *) "
"S0" " FIRSTFILBUF = 248 ; (* = LCAFTMST+RUNCHKAREA+DSPLYAREA *) "
"S0" " LASTFILBUF = 280 ; (* LAST FILE BUFFER / FIRST PROG. VARIABLE *) "
"S1" (* 'S1' CONSTANT DEFINITION *)
"S1" REGPRMAREA = 40 ; (* SHOULD BE A MULTIPLE OF '4' BYTES *)
"S1" LCAFTMST = 8 ; FPSAVEAREA = 0 ; RUNCHKAREA = 0 ; DSPLYAREA = 0 ;
"S1" FNCRSLT = 0 ; FIRSTFILBUF = 12 ; LASTFILBUF = 44 ;
### REALLNGTH = 20 ; DIGMAX = 19 (* REALLNGHT-1*) ; IDLNGTH = 12 ;
# STRGLNGTH = 64;" MAXINT = 2147483647;" (*XSL10*)
MAXINT = 34359738367; (*XSL10*)
(*SETCH...*)
"EJG Temporarily patch these values for old-fashioned, short sets 11/11/78
MAXSETEL = 143; (*MAX LEGAL (ORDINAL) VALUE OF A SET MEMBER*)
HOST_SET_SIZE = 64; (*NUMBER OF SET ELEMENTS IN THE HOST COMPILER*)
HOST_SET_MAX = 63; (*MAX LEGAL VALUE FOR A HOST SET ELEMENT*)
SETREP_MAX = 2; (*NUMBER OF HOST SETS USED TO REP SETS - 1*)
NUMOFSETOPND = 9; (*NUMBER OF OPERANDS OUTPUT FOR PCODE *)
EJG"
MAXSETEL = 63; (*MAX LEGAL (ORDINAL) VALUE OF A SET MEMBER*)
HOST_SET_SIZE = 64; (*NUMBER OF SET ELEMENTS IN THE HOST COMPILER*)
HOST_SET_MAX = 63; (*MAX LEGAL VALUE FOR A HOST SET ELEMENT*)
(*The following "1" should be "0", but triggers PCPASC 0..0 bug*)
SETREP_MAX = 1; (*NUMBER OF HOST SETS USED TO REP SETS - 1*)
NUMOFSETOPND = 4; (*NUMBER OF OPERANDS OUTPUT FOR PCODE *)
(*...SETCH*) (* LDC S,(---) INSTRUCTION*)
# OPMAX = 64 ; (* OPCODE RANGE *)
# BLANK12 = ' ' ;
# NRSW = 37 ;
NRSW_P1 = 38 ; (*NRSW + 1*) (*PEG*)
# NSPROC = 32 ;
"CTR" MAXCTR = 16384 ;
STD_CHCNTMAX = 301 ; (*MAX NUMBER OF CH IN ONE LINE + 1*)(*PEG*)
DEF_CHCNTMAX = 81 ; (*DEFAULT VALUE FOR CHCNTMAX*) (*PEG*)
TYPE (*DESCRIBING:*)
(*************)
(*BASIC SYMBOLS*)
(***************)
SYMBOL = (IDENT,INTCONST,REALCONST,STRINGCONST,NOTSY,MULOP,ADDOP,RELOP,
LPARENT,RPARENT,LBRACK,RBRACK,COMMA,SEMICOLON,PERIOD,ARROW,
COLON,DOTDOT,BECOMES,LABELSY,CONSTSY,TYPESY,VARSY,FUNCSY,PROGSY,
PROCSY,SETSY,PACKEDSY,ARRAYSY,RECORDSY,FILESY,FORWARDSY,
BEGINSY,IFSY,CASESY,REPEATSY,WHILESY,FORSY,WITHSY,
GOTOSY,ENDSY,ELSESY,UNTILSY,OFSY,DOSY,TOSY,DOWNTOSY,
# # THENSY,FRTRNSY,EXTRNSY,OTHERSY);
OPERATOR = (MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP,LTOP,LEOP,GEOP,GTOP,
NEOP,EQOP,INOP,NOOP);
SETOFSYS = SET OF SYMBOL;
(*SETCH...*)
SETREP_INDEX = 0..SETREP_MAX;
SET_EL_TYP = 0..MAXSETEL;
SETREP = ARRAY[SETREP_INDEX] OF SET OF 0..HOST_SET_MAX;
(*...SETCH*)
(*CONSTANTS*)
(***********)
CSTCLASS = (REEL,PSET,STRG);
CSP = ↑ CONSTANT;
CONSTANT = RECORD CASE "CCLASS:" CSTCLASS OF
REEL: (RVAL: PACKED ARRAY [1..REALLNGTH] OF CHAR);
PSET: (PVAL: SETREP); (*SETCH*)
"(PVAL: SET OF 0..MAXSETEL);" (*SETCH*)
STRG: (SLNGTH: 0..STRGLNGTH;
SVAL: PACKED ARRAY [1..STRGLNGTH] OF CHAR)
END;
VALU = RECORD CASE "INTVAL:" BOOLEAN OF (*INTVAL NEVER SET NORE TESTED*)
TRUE: (IVAL: INTEGER);
FALSE: (VALP: CSP)
END;
(*DATA STRUCTURES*)
(*****************)
LEVRANGE = 0..MAXLEVEL; ADDRRANGE = 0..MAXADDR;
ALNRNG = 1..8 ; LABELRNG = 0..1000 ;
STRUCTFORM = (SCALAR,SUBRANGE,POINTER,POWER,ARRAYS,RECORDS,FILES,
TAGFLD,VARIANT);
DECLKIND = (STANDARD,DECLARED);
STP = ↑ STRUCTURE; CTP = ↑ IDENTIFIER;
STRUCTURE = PACKED RECORD
(* MARKED: BOOLEAN; TO BE USED WITH 'T+', FOR TEST PHASE ONLY*)
ALN : ALNRNG ; (*REQUIRED ALIGNMENT *)
SIZE: ADDRRANGE;
CASE FORM: STRUCTFORM OF
SCALAR: (CASE SCALKIND: DECLKIND OF
DECLARED: (FCONST: CTP));
SUBRANGE: (RANGETYPE: STP; MIN,MAX: VALU);
POINTER: (ELTYPE: STP);
POWER: (ELSET: STP);
ARRAYS: (AELTYPE,INXTYPE: STP);
RECORDS: (FSTFLD: CTP; RECVAR: STP);
FILES: (FILTYPE: STP);
TAGFLD: (TAGFIELDP: CTP; FSTVAR: STP);
VARIANT: (NXTVAR,SUBVAR: STP; VARVAL: VALU)
END;
(*NAMES*)
(*******)
IDCLASS = (TYPES,KONST,VARS,FIELD,PROC,FUNC);
SETOFIDS = SET OF IDCLASS;
IDKIND = (ACTUAL,FORMAL);
ALPHA = PACKED ARRAY [1..IDLNGTH] OF CHAR;
IDENTIFIER = PACKED RECORD
NAME: ALPHA; LLINK, RLINK: CTP;
IDTYPE: STP; NEXT: CTP;
CASE KLASS: IDCLASS OF
KONST: (VALUES: VALU);
# VARS: (VKIND: IDKIND; EBCD: BOOLEAN ;
VLEV: LEVRANGE; VADDR: ADDRRANGE);
FIELD: (FLDADDR: ADDRRANGE);
PROC,
FUNC: (CASE PFDECKIND: DECLKIND OF
STANDARD: (KEY: 1..NSPROC);
DECLARED: (PFLEV: LEVRANGE; PFNAME: LABELRNG;
"S1" FPRMSZE,RPRMSZE,SPRMSZE: ADDRRANGE;
CASE PFKIND: IDKIND OF
ACTUAL: (FWDECL, EXTRN,FRTRN,SAVEFP:
BOOLEAN)))
END;
DISPRANGE = 0..DISPLIMIT;
WHERE = (BLCK,CREC,VREC,REC);
(*EXPRESSIONS*)
(*************)
ATTRKIND = (CST,VARBL,EXPR);
VACCESS = (DRCT,INDRCT,INXD);
# ATTR = RECORD TYPTR, BTYPE: STP;
CASE KIND: ATTRKIND OF
CST: (CVAL: VALU);
VARBL: (CASE ACCESS: VACCESS OF
DRCT: (VLEVEL: LEVRANGE; DPLMT: ADDRRANGE);
INDRCT: (IDPLMT: ADDRRANGE))
END;
TESTP = ↑ TESTPOINTER;
TESTPOINTER = PACKED RECORD
ELT1,ELT2 : STP;
LASTTESTP : TESTP
END;
(*LABELS*)
(********)
LBP = ↑ LABL;
LABL = RECORD NEXTLAB: LBP; DEFINED: BOOLEAN;
LABVAL, LABNAME: INTEGER
END;
EXTFILEP = ↑FILEREC;
FILEREC = RECORD FILENAME:ALPHA; NEXTFILE:EXTFILEP; GEBCDFIL: BOOLEAN END;
"CTR" CTRRANGE = 0..MAXCTR;
"CTR" CTRTYPE = (CTRPROC, CTRLBL, CTRGOTO, CTRIF, CTRWHILE, CTRREPEAT,
"CTR" CTRFOR, CTRCASE);
(*-------------------------------------------------------------------------*)
VAR
PRD,PRR,QRR,QRD: TEXT; (*FILES MUST BE PRE-DECLARED*) (*XSL10*) (*X10S1*)
"E" SYMTBL:TEXT;
# ERRORCOUNT, CTIME: INTEGER; (*TOTAL ERROR COUNT*)
(*RETURNED BY SOURCE PROGRAM SCANNER INSYMBOL:*)
(**********************************************)
SY: SYMBOL; (*LAST SYMBOL*)
OP: OPERATOR; (*CLASSIFICATION OF LAST SYMBOL*)
VAL: VALU; (*VALUE OF LAST CONSTANT*)
LNGTH: INTEGER; (*LENGTH OF LAST STRING CONSTANT*)
ID: ALPHA ; (*LAST IDENTIFIER (POSSIBLY TRUNCATED)*)
KK: 1..IDLNGTH; (*NR OF CHARS IN LAST IDENTIFIER*)
CH: CHAR; (*LAST CHARACTER READ*)
EOL: BOOLEAN; (*END OF LINE FLAG*)
(*COUNTERS:*)
(***********)
CHCNT, (*CHARACTER COUNTER*) (*PEG*)
CHCNTMAX, (*MAX LINE LENGTH*) (*PEG*)
CURLINLEN: 0..STD_CHCNTMAX; (*LENGTH OF CURRENT LINE + 1*) (*PEG*)
LC,IC,OLDIC: ADDRRANGE ; (*DATA LOCATION AND INSTRUCTION COUNTER*)
# LINECOUNT ,MXDATASZE: INTEGER;
(*SWITCHES:*)
(***********)
DP, (*DECLARATION PART*)
PRTERR, (*TO ALLOW FORWARD REFERENCES IN PTR TYPE
(*DECLARATION BY SUPPRESSING ERROR MSG*)
ENDFLG, (*SY=END*)
# DOTFLG, (*ONE DOT ALREADY SEEN*)
# ASSIGN,PACKDATA, (*ASSIGNMENT GOING ON, WORD ALIGN FLAG *)
# LIST,PRCODE,PRTABLES,PRTIC,
# SEQNUMBERS,DEBUG,BYTEON,
# (*OUTPUT OPTIONS FOR
# --> SOURCE PROGRAM LISTING
# --> PRINTING SYMBOLIC CODE
# --> DISPLAYING IDENT AND STRUCT TABLES
# --> LAST 8 COLS. OF INPUT INTERPRETED
AS SEQUENCE NUMBERS-- PEG
# --> PRINT INST_CNTR, PROCEDURE OPTION*)
#
# ASSEMBLE,ASMVERB,EBCDFLG, XLINK,
# SAVEREGS,SAVEFPRS,GET_STAT: BOOLEAN;
# (*POST PROCESSOR OPTIONS*)
#
(*POINTERS:*)
(***********)
INTPTR,REALPTR,CHARPTR,BOOLPTR,
NILPTR,TEXTPTR,ALFAPTR: STP; (*POINTERS TO ENTRIES OF STANDARD IDS*)
UTYPPTR,UCSTPTR,UVARPTR,
UFLDPTR,UPRCPTR,UFCTPTR, (*POINTERS TO ENTRIES FOR UNDECLARED IDS*)
FWPTR: CTP; (*HEAD OF CHAIN OF FORW DECL TYPE IDS*)
FEXTFILEP: EXTFILEP; (*HEAD OF CHAIN OF EXTERNAL FILES*)
GLOBTESTP: TESTP; (*LAST TESTPOINTER*)
(*BOOKKEEPING OF DECLARATION LEVELS:*)
(************************************)
LEVEL: LEVRANGE; (*CURRENT STATIC LEVEL*)
DISX, (*LEVEL OF LAST ID SEARCHED BY SEARCHID*)
TOP: DISPRANGE; (*TOP OF DISPLAY*)
DISPLAY: (*WHERE: MEANS:*)
ARRAY [DISPRANGE] OF
PACKED RECORD (*=BLCK: ID IS VARIABLE ID*)
FNAME: CTP; FLABEL: LBP; (*=CREC: ID IS FIELD ID IN RECORD WITH*)
CASE OCCUR: WHERE OF (* CONSTANT ADDRESS*)
CREC: (CLEV: LEVRANGE; (*=VREC: ID IS FIELD ID IN RECORD WITH*)
CDSPL: ADDRRANGE);(* VARIABLE ADDRESS*)
VREC: (VDSPL: ADDRRANGE)
END; (* --> PROCEDURE WITHSTATEMENT*)
(*ERROR MESSAGES:*)
(*****************)
ERRINX: 0..10; (*NR OF ERRORS IN CURRENT SOURCE LINE*)
ERRLIST:
ARRAY [1..10] OF
PACKED RECORD POS: 1..81;
NMR: 1..400
END;
(*EXPRESSION COMPILATION:*)
(*************************)
GATTR: ATTR; (*DESCRIBES THE EXPR CURRENTLY COMPILED*)
NULL_SET: SETREP;
(*STRUCTURED CONSTANTS:*)
(***********************)
# ATOZ, NUMERIC,
# ALPHANUMERIC : SET OF CHAR ; (*VALID ALPHA-NUMERICS*)
# LINEBUF: ARRAY[1..STD_CHCNTMAX] OF CHAR ; (*CURRENT LINE BUFFER*) (*PEG*)
# SEQFLD: ARRAY [1..8] OF CHAR ; (*SEQ. NUM. FIELD OF INPUT LINE, $M+ ONLY*)
CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEBEGSYS,BLOCKBEGSYS,SELECTSYS,FACBEGSYS,
STATBEGSYS,TYPEDELS: SETOFSYS;
## NXTFILBUF : ADDRRANGE ;
### CALL_LVL : ARRAY[BOOLEAN] OF INTEGER ;
RW: ARRAY [1..NRSW(*NR. OF RES. WORDS*)] OF ALPHA;
FRW: ARRAY [1..14] OF 1..NRSW_P1 (*NR. OF RES. WORDS + 1*); (*PEG*)
RSY: ARRAY [1..NRSW(*NR. OF RES. WORDS*)] OF SYMBOL;
"SSY: ARRAY ['+'..';'] OF SYMBOL;" (*XSL10*)
SSY: ARRAY [' '..'←'] OF SYMBOL; (*XSL10*)
ROP: ARRAY [1..NRSW(*NR. OF RES. WORDS*)] OF OPERATOR;
"SOP: ARRAY ['+'..';'] OF OPERATOR;" (*XSL10*)
SOP: ARRAY [' '..'←'] OF OPERATOR; (*XSL10*)
NA: ARRAY [1..45] OF ALPHA;
MN: ARRAY [0..OPMAX] OF PACKED ARRAY [1..4] OF CHAR;
SNA: ARRAY [1..32] OF PACKED ARRAY [1..3] OF CHAR;
# INTLABEL,PROCLAB: LABELRNG ; MXINT10: INTEGER;
"CTR" CTRCNT : CTRRANGE ;
"CTR" CTRCNTLBL : LABELRNG ;
"CTR" CTROPTION : BOOLEAN;
"CTR" " FIRSTCTR : BOOLEAN; "
"S1" FPRM1, SPRM1, RPRM1 : ADDRRANGE ; REGS_FULL: BOOLEAN ;
(*-------------------------------------------------------------------------*)
(** ERREXIT PRINTERROR FILL_BUFFER LISTLINE SKIP_E_DIRECTORY ENDOFLINE ERROR **)
PROCEDURE ERREXIT (CODE : INTEGER); (*XSL10*)
BEGIN (*XSL10*)
WRITELN(OUTPUT,'**** ERREXIT CALLED WITH CODE =',CODE); (*XSL10*)
(* EXIT(CODE) *) (*X10S1*)
HALT (*XSL10*) (*X10S1*)
END; (*XSL10*)
PROCEDURE PRINTERROR ;
VAR LASTPOS,FREEPOS,CURRPOS,CURRNMR,F,K: INTEGER;
# BEGIN
# IF NOT LIST THEN
# BEGIN
# IF SEQNUMBERS THEN WRITE(OUTPUT, SEQFLD:9) ELSE WRITELN(OUTPUT,LINECOUNT:9) ;
# WRITELN(OUTPUT, ' ':13, LINEBUF:80) ;
# END ;
# (*OUTPUT ERROR MESSAGES*)
# WRITE(OUTPUT,'****':12, ' ':10) ;
# LASTPOS := 0; FREEPOS := 1;
# FOR K := 1 TO ERRINX DO
# BEGIN
# WITH ERRLIST[K] DO
# BEGIN CURRPOS := POS; CURRNMR := NMR END;
# IF CURRPOS = LASTPOS THEN WRITE(OUTPUT,',')
# ELSE
# BEGIN
# WHILE FREEPOS < CURRPOS DO
# BEGIN WRITE(OUTPUT,' '); FREEPOS := FREEPOS + 1 END;
# WRITE(OUTPUT,'↑');
# LASTPOS := CURRPOS
# END;
# IF CURRNMR < 10 THEN F := 1
# ELSE IF CURRNMR < 100 THEN F := 2
# ELSE F := 3;
# WRITE(OUTPUT,CURRNMR:F);
# FREEPOS := FREEPOS + F + 1
# END;
# WRITELN(OUTPUT); ERRINX := 0 ; PRCODE := FALSE ;
# END (*PRINTERROR*) ;
PROCEDURE FILL_BUFFER; (*PEG...*)
VAR I: 0..STD_CHCNTMAX;
BEGIN
I := 0;
WHILE (I < CHCNTMAX - 1) AND NOT EOLN(INPUT) DO
BEGIN
I := I + 1;
READ(INPUT,LINEBUF[I]);
END;
I := I + 1;
LINEBUF[I] := ' ';
CURLINLEN := I + 1;
READLN(INPUT);
END; (*FILL_BUFFER*) (*...PEG*)
PROCEDURE LISTLINE; (*PEG...*)
VAR I: 0..STD_CHCNTMAX;
BEGIN
IF SEQNUMBERS THEN WRITE(OUTPUT, SEQFLD:9)
ELSE WRITE(OUTPUT,LINECOUNT: 9) ;
IF DP THEN WRITE(OUTPUT,LC:8) ELSE WRITE(OUTPUT,IC:8);
WRITE(OUTPUT,LEVEL:3,') ') ;
FOR I := 1 TO CURLINLEN - 1 DO WRITE(OUTPUT, LINEBUF[I]);
WRITELN(OUTPUT);
END; (*LISTLINE*) (*...PEG*)
PROCEDURE SKIP_E_DIRECTORY; (*XSL10...*)
VAR
I: INTEGER; CH: CHAR;
FIRST_SEVEN: PACKED ARRAY[1..7] OF CHAR;
BEGIN
FILL_BUFFER;
FOR I:=1 TO 7 DO
FIRST_SEVEN[I] := LINEBUF[I];
IF FIRST_SEVEN = 'COMMENT' THEN
BEGIN
REPEAT
READ(INPUT,CH);
UNTIL CH = ';';
READLN(INPUT);
FILL_BUFFER;
END;
LISTLINE;
END; (*SKIP_E_DIR*) (*...XSL10*)
PROCEDURE ENDOFLINE ;
VAR I: 0..STD_CHCNTMAX; (*PEG*) (*XSL10*)
BEGIN IF ERRINX > 0 THEN PRINTERROR ; (*XSL10*)
IF SEQNUMBERS THEN (*PEG*)
FOR I := CHCNTMAX - 8 TO CHCNTMAX - 1 (*PEG*)
DO LINEBUF[I] := ' '; (*PEG*) (*XSL10*)
FILL_BUFFER; (*PEG*)
# IF SEQNUMBERS THEN (*PEG*)
# FOR I := 1 TO 8 DO (*PEG*)
# BEGIN SEQFLD[I] := LINEBUF[CHCNTMAX - (9-I)] ; (*PEG*)
LINEBUF[CHCNTMAX - (9-I)] := ' ' END ; (*PEG*)
# LINECOUNT := LINECOUNT+1 ;
IF LIST THEN LISTLINE; (*PEG*)
CHCNT := 0
END (*ENDOFLINE*) ;
PROCEDURE ERROR(FERRNR: INTEGER);
BEGIN
IF ERRINX >= 9 THEN
BEGIN ERRLIST[10].NMR := 255; ERRINX := 10 END
ELSE
BEGIN ERRINX := ERRINX + 1;
ERRLIST[ERRINX].NMR := FERRNR
END;
ERRLIST[ERRINX].POS := CHCNT ;
# ERRORCOUNT := ERRORCOUNT+1 ;
END (*ERROR*) ;
(** INSYMBOL SKIPBLNK NEXTCH OPTIONS **)
PROCEDURE INSYMBOL;
(*READ NEXT BASIC SYMBOL OF SOURCE PROGRAM AND RETURN ITS
DESCRIPTION IN THE GLOBAL VARIABLES SY, OP, ID, VAL AND LNGTH*)
LABEL 1,2,3;
VAR I,K: INTEGER;
DIGIT: PACKED ARRAY [1..REALLNGTH] OF CHAR;
STRING: PACKED ARRAY [1..STRGLNGTH] OF CHAR;
LVP: CSP;TEST: BOOLEAN;
#
#
# PROCEDURE SKIPBLNK;
# (* SKIP BLANKS, ENDOFLINE, AND (OPTIONAL) MARGIN, SKIPS AT LEAST ONE CHAR *)
#
# BEGIN
# REPEAT
# IF EOL THEN
# BEGIN
# IF EOF(INPUT) THEN
# BEGIN WRITELN(OUTPUT,'**** EOF ENCOUNTERED':24) ;
# ERREXIT(ERRORCOUNT+1) ; (*XSL10*)
# END ;
# ENDOFLINE ;
# END;
# REPEAT
CHCNT := CHCNT+1 ;
UNTIL (LINEBUF[CHCNT] <> ' ') OR (CHCNT = CURLINLEN); (*PEG*)
# EOL := CHCNT = CURLINLEN; (*PEG*)
# UNTIL NOT EOL ;
# CH := LINEBUF[CHCNT] ;
EOL := (CHCNT + 1) = CURLINLEN; (*PEG*)
# END (*SKIPBLNK*) ;
PROCEDURE NEXTCH;
BEGIN
IF EOL THEN
BEGIN
IF EOF(INPUT) THEN
BEGIN WRITELN(OUTPUT,'**** EOF ENCOUNTERED':24) ;
ERREXIT(ERRORCOUNT+1) ; (*XSL10*)
END ;
ENDOFLINE ;
END;
CHCNT := CHCNT+1 ;
CH := LINEBUF[CHCNT] ;
EOL := CHCNT + 1 = CURLINLEN; (*PEG*)
END;
PROCEDURE OPTIONS;
BEGIN
REPEAT NEXTCH;
IF CH <> '*' THEN
BEGIN
IF CH = 'T' THEN
BEGIN NEXTCH; PRTABLES := CH = '+' END
ELSE
IF CH = 'L' THEN
BEGIN NEXTCH; LIST := CH = '+';
" IF NOT LIST THEN WRITELN(OUTPUT) "
END
ELSE
IF CH = 'C' THEN
BEGIN NEXTCH; PRCODE := CH = '+' END
ELSE
IF CH = 'E' THEN
# BEGIN NEXTCH ;
# EBCDFLG := CH = '+' ;
# END
# ELSE
# IF CH = 'A' THEN
# BEGIN NEXTCH ; ASSEMBLE := CH ='+' END
# ELSE
# IF CH='M' THEN
# BEGIN
NEXTCH; (*PEG...*)
CHCNTMAX := 0;
WHILE (CH IN NUMERIC) DO
BEGIN
CHCNTMAX := CHCNTMAX*10 + (ORD(CH)-ORD('0'));
NEXTCH;
END;
IF (CHCNTMAX = 0) OR (CHCNTMAX < 8)
OR (CHCNTMAX > STD_CHCNTMAX - 1) THEN
CHCNTMAX := DEF_CHCNTMAX
ELSE CHCNTMAX := CHCNTMAX + 1;
CHCNT := CHCNT - 1; (*BACK UP ONE CHAR*)
END
ELSE
IF CH='N' THEN
BEGIN
NEXTCH;
SEQNUMBERS := CH = '+';
END (*...PEG*)
# ELSE
# IF CH = 'S' THEN
# BEGIN NEXTCH ; SAVEREGS := CH <> '-' END
# ELSE
# IF CH = 'F' THEN
# BEGIN NEXTCH ; SAVEFPRS := CH <> '-' ;
# END
# ELSE
# IF CH = 'D' THEN
# BEGIN NEXTCH ; DEBUG := CH <> '-' END
# ELSE
# IF CH = 'P' THEN
# BEGIN NEXTCH ; PACKDATA := CH = '+' ;
# (*LCW IF PACKDATA THEN MXDATASZE := INTSIZE *)
# (*LCW ELSE MXDATASZE := REALSIZE ; *)
# END
# ELSE
# IF CH = 'B' THEN
# BEGIN NEXTCH ; BYTEON := CH = '+' ;
# DEBUG := BYTEON ;
# END
# ELSE
# IF CH = 'V' THEN
# BEGIN NEXTCH ; ASMVERB := CH ='+' END
# ELSE
# IF CH = 'U' THEN
# BEGIN NEXTCH ; GET_STAT := CH = '+' END
# ELSE
# IF CH = 'X' THEN
# BEGIN NEXTCH; XLINK := CH = '+' END
# ELSE IF CH = 'K' THEN
# BEGIN NEXTCH;
"CTR" CTROPTION := CH = '+' ;
"CTR" IF CTROPTION THEN REWRITE(QRD) ;
# END ;
NEXTCH
END
UNTIL CH <> ','
END (*OPTIONS*) ;
BEGIN (*INSYMBOL*)
1:
# IF CH = ' ' THEN SKIPBLNK ;
CASE CH OF
'A','B','C','D','E','F','G','H','I',
'J','K','L','M','N','O','P','Q','R',
'S','T','U','V','W','X','Y','Z':
# BEGIN K := 0 ; ID := BLANK12 ;
REPEAT
IF K < IDLNGTH THEN
BEGIN K := K + 1; ID[K] := CH END ;
NEXTCH
# UNTIL NOT(CH IN ALPHANUMERIC) ;
" IF K >= KK THEN KK := K
ELSE
REPEAT ID[KK] := ' '; KK := KK - 1
UNTIL KK = K; "
FOR I := FRW[K] TO FRW[K+1] - 1 DO
IF RW[I] = ID THEN
BEGIN SY := RSY[I]; OP := ROP[I]; GOTO 2 END;
SY := IDENT; OP := NOOP;
2: END;
'0','1','2','3','4','5','6','7','8','9':
BEGIN OP := NOOP; I := 0;
REPEAT I := I+1; IF I<= DIGMAX THEN DIGIT[I] := CH; NEXTCH
UNTIL NOT (CH IN NUMERIC) ;
IF (CH = '.') OR (CH = 'E') THEN
BEGIN
K := I;
IF CH = '.' THEN
BEGIN K := K+1; IF K <= DIGMAX THEN DIGIT[K] := CH;
NEXTCH;
# IF CH = '.' THEN BEGIN DOTFLG := TRUE; GOTO 3 END;
IF NOT (CH IN NUMERIC) THEN
ERROR(201)
ELSE
REPEAT K := K + 1;
IF K <= DIGMAX THEN DIGIT[K] := CH; NEXTCH
UNTIL NOT (CH IN NUMERIC)
END;
IF CH = 'E' THEN
BEGIN K := K+1; IF K <= DIGMAX THEN DIGIT[K] := CH;
NEXTCH;
IF (CH = '+') OR (CH ='-') THEN
BEGIN K := K+1; IF K <= DIGMAX THEN DIGIT[K] := CH;
NEXTCH
END;
IF NOT (CH IN NUMERIC) THEN
ERROR(201)
ELSE
REPEAT K := K+1;
IF K <= DIGMAX THEN DIGIT[K] := CH; NEXTCH
UNTIL NOT (CH IN NUMERIC)
END;
NEW(LVP,REEL); SY:= REALCONST; "LVP↑.CCLASS := REEL;"
WITH LVP↑ DO
BEGIN FOR I := 1 TO REALLNGTH DO RVAL[I] := ' ';
IF K <= DIGMAX THEN
FOR I := 2 TO K + 1 DO RVAL[I] := DIGIT[I-1]
ELSE BEGIN ERROR(203); RVAL[2] := '0';
RVAL[3] := '.'; RVAL[4] := '0'
END
END;
VAL.VALP := LVP
END
ELSE
3: BEGIN
IF I > DIGMAX THEN BEGIN ERROR(203); VAL.IVAL := 0 END
ELSE
WITH VAL DO
BEGIN IVAL := 0;
FOR K := 1 TO I DO
BEGIN
IF IVAL <= MXINT10 THEN
IVAL := IVAL*10 + (ORD(DIGIT[K])-ORD('0'))
ELSE BEGIN ERROR(203); IVAL := 0 END
END;
SY := INTCONST
END
END
END;
'''':
BEGIN LNGTH := 0; SY := STRINGCONST; OP := NOOP;
REPEAT
REPEAT NEXTCH; LNGTH := LNGTH + 1;
IF LNGTH <= STRGLNGTH THEN STRING[LNGTH] := CH
UNTIL (EOL) OR (CH = '''');
IF EOL THEN ERROR(202) ELSE NEXTCH
UNTIL CH <> '''';
LNGTH := LNGTH - 1; (*NOW LNGTH = NR OF CHARS IN STRING*)
IF LNGTH = 1 THEN VAL.IVAL := ORD(STRING[1])-CHARDIF (*CHARDIF*)
ELSE
BEGIN NEW(LVP,STRG); "LVP↑.CCLASS:=STRG;"
IF LNGTH > STRGLNGTH THEN
BEGIN ERROR(398); LNGTH := STRGLNGTH END;
WITH LVP↑ DO
BEGIN SLNGTH := LNGTH;
FOR I := 1 TO LNGTH DO SVAL[I] := STRING[I]
END;
VAL.VALP := LVP
END
END;
':':
BEGIN OP := NOOP; NEXTCH;
IF CH = '=' THEN
BEGIN SY := BECOMES; NEXTCH END
ELSE SY := COLON
END;
'.':
BEGIN OP := NOOP;
IF NOT ENDFLG THEN
BEGIN
IF NOT DOTFLG THEN NEXTCH;
IF CH = '.' THEN
BEGIN SY := DOTDOT; DOTFLG := FALSE ; NEXTCH END
ELSE SY := PERIOD;
END
ELSE SY := PERIOD;
END;
'<':
BEGIN NEXTCH; SY := RELOP;
IF CH = '=' THEN
BEGIN OP := LEOP; NEXTCH END
ELSE
IF CH = '>' THEN
BEGIN OP := NEOP; NEXTCH END
ELSE OP := LTOP
END;
'>':
BEGIN NEXTCH; SY := RELOP;
IF CH = '=' THEN
BEGIN OP := GEOP; NEXTCH END
ELSE OP := GTOP
END;
'(':
BEGIN NEXTCH;
IF CH = '*' THEN
BEGIN NEXTCH;
IF CH = '$' THEN OPTIONS;
REPEAT
WHILE CH <> '*' DO NEXTCH;
NEXTCH
UNTIL CH = ')';
NEXTCH; GOTO 1
END ;
# IF CH = '/' THEN
# BEGIN SY := LBRACK ; OP := NOOP ;
# NEXTCH
# END
ELSE BEGIN SY := LPARENT; OP := NOOP END
END;
# '[',']', (*XSL10*)
# '*','+','-','%',
# '=','/',')','&',"'|','¬'," (*XSL10*)
# '!','?',',',';','↑','$':
BEGIN SY := SSY[CH]; OP := SOP[CH];
# IF CH = '/' THEN
# BEGIN NEXTCH ;
# IF CH =')' THEN
# BEGIN SY := RBRACK ; OP := NOOP ;
# NEXTCH ;
# END
# END
# ELSE NEXTCH
END;
# '"':
# BEGIN REPEAT NEXTCH UNTIL CH = '"' ;
# NEXTCH ; GOTO 1 ;
# END ;
# '#':
# BEGIN NEXTCH ; GOTO 1 END ;
# '@','←': (*XSL10*)
# BEGIN SY := OTHERSY; OP := NOOP; ERROR(398) ; NEXTCH END
END (*CASE*)
END (*INSYMBOL*) ;
(** ENTERID SEARCHSECTION SEARCHID GETBOUNDS **)
PROCEDURE ENTERID(FCP: CTP);
(*ENTER ID POINTED AT BY FCP INTO THE NAME-TABLE,
WHICH ON EACH DECLARATION LEVEL IS ORGANISED AS
AN UNBALANCED BINARY TREE*)
VAR NAM: ALPHA; LCP, LCP1: CTP; LLEFT: BOOLEAN;
BEGIN NAM := FCP↑.NAME;
LCP := DISPLAY[TOP].FNAME;
IF LCP = NIL THEN
DISPLAY[TOP].FNAME := FCP
ELSE
BEGIN
REPEAT LCP1 := LCP;
IF LCP↑.NAME = NAM THEN (*NAME CONFLICT, FOLLOW RIGHT LINK*)
BEGIN ERROR(101); LCP := LCP↑.RLINK; LLEFT := FALSE END
ELSE
IF LCP↑.NAME < NAM THEN
BEGIN LCP := LCP↑.RLINK; LLEFT := FALSE END
ELSE BEGIN LCP := LCP↑.LLINK; LLEFT := TRUE END
UNTIL LCP = NIL;
IF LLEFT THEN LCP1↑.LLINK := FCP ELSE LCP1↑.RLINK := FCP
END;
FCP↑.LLINK := NIL; FCP↑.RLINK := NIL
END (*ENTERID*) ;
PROCEDURE SEARCHSECTION(FCP: CTP; VAR FCP1: CTP);
(*TO FIND RECORD FIELDS AND FORWARD DECLARED PROCEDURE ID'S
--> PROCEDURE PROCEDUREDECLARATION
--> PROCEDURE SELECTOR*)
LABEL 1;
BEGIN
WHILE FCP <> NIL DO
IF FCP↑.NAME = ID THEN GOTO 1
ELSE IF FCP↑.NAME < ID THEN FCP := FCP↑.RLINK
ELSE FCP := FCP↑.LLINK;
1: FCP1 := FCP
END (*SEARCHSECTION*) ;
PROCEDURE SEARCHID(FIDCLS: SETOFIDS; VAR FCP: CTP);
LABEL 1;
VAR LCP: CTP;
BEGIN
FOR DISX := TOP DOWNTO 0 DO
BEGIN LCP := DISPLAY[DISX].FNAME;
WHILE LCP <> NIL DO
IF LCP↑.NAME = ID THEN
IF LCP↑.KLASS IN FIDCLS THEN GOTO 1
ELSE
BEGIN IF PRTERR THEN ERROR(103);
LCP := LCP↑.RLINK
END
ELSE
IF LCP↑.NAME < ID THEN
LCP := LCP↑.RLINK
ELSE LCP := LCP↑.LLINK
END;
(*SEARCH NOT SUCCSESSFUL; SUPPRESS ERROR MESSAGE IN CASE
OF FORWARD REFERENCED TYPE ID IN POINTER TYPE DEFINITION
--> PROCEDURE SIMPLETYPE*)
IF PRTERR THEN
BEGIN ERROR(104);
(*TO AVOID RETURNING NIL, REFERENCE AN ENTRY
FOR AN UNDECLARED ID OF APPROPRIATE CLASS
--> PROCEDURE ENTERUNDECL*)
IF TYPES IN FIDCLS THEN LCP := UTYPPTR
ELSE
IF VARS IN FIDCLS THEN LCP := UVARPTR
ELSE
IF FIELD IN FIDCLS THEN LCP := UFLDPTR
ELSE
IF KONST IN FIDCLS THEN LCP := UCSTPTR
ELSE
IF PROC IN FIDCLS THEN LCP := UPRCPTR
ELSE LCP := UFCTPTR;
END;
1: FCP := LCP
END (*SEARCHID*) ;
PROCEDURE GETBOUNDS(FSP: STP; VAR FMIN,FMAX: INTEGER);
(*GET INTERNAL BOUNDS OF SUBRANGE OR SCALAR TYPE*)
(*ASSUME (FSP <> NIL) AND (FSP↑.FORM <= SUBRANGE) AND (FSP <> INTPTR)
AND NOT COMPTYPES(REALPTR,FSP)*)
BEGIN
WITH FSP↑ DO
IF FORM = SUBRANGE THEN
BEGIN FMIN := MIN.IVAL; FMAX := MAX.IVAL END
ELSE
BEGIN FMIN := 0;
# IF FSP = CHARPTR THEN IF BYTEON THEN FMAX := 255 ELSE FMAX := 63
ELSE
IF (FORM = SCALAR) AND (FSP↑.FCONST <> NIL) THEN
FMAX := FSP↑.FCONST↑.VALUES.IVAL
ELSE FMAX := 0
END
END (*GETBOUNDS*) ;
(** PRINTTABLES MARKER MARKCTP MARKSTP MARKCTP FOLLOWCTP FOLLOWSTP **)
" PROCEDURE PRINTTABLES(FB: BOOLEAN);
(*PRINT DATA STRUCTURE AND NAME TABLE*)
VAR I, LIM: DISPRANGE;
PROCEDURE MARKER;
(*MARK DATA STRUCTURE ENTRIES TO AVOID MULTIPLE PRINTOUT*)
VAR I: INTEGER;
PROCEDURE MARKCTP(FP: CTP); FORWARD;
PROCEDURE MARKSTP(FP: STP);
(*MARK DATA STRUCTURES, PREVENT CYCLES*)
BEGIN
IF FP <> NIL THEN
WITH FP↑ DO
BEGIN MARKED := TRUE;
CASE FORM OF
SCALAR: ;
SUBRANGE: MARKSTP(RANGETYPE);
POINTER: (*DON'T MARK ELTYPE: CYCLE POSSIBLE; WILL BE MARKED
ANYWAY, IF FP = TRUE*) ;
POWER: MARKSTP(ELSET) ;
ARRAYS: BEGIN MARKSTP(AELTYPE); MARKSTP(INXTYPE) END;
RECORDS: BEGIN MARKCTP(FSTFLD); MARKSTP(RECVAR) END;
FILES: MARKSTP(FILTYPE);
TAGFLD: MARKSTP(FSTVAR);
VARIANT: BEGIN MARKSTP(NXTVAR); MARKSTP(SUBVAR) END
END (*CASE*)
END (*WITH*)
END (*MARKSTP*);
PROCEDURE MARKCTP;
BEGIN
IF FP <> NIL THEN
WITH FP↑ DO
BEGIN MARKCTP(LLINK); MARKCTP(RLINK);
MARKSTP(IDTYPE)
END
END (*MARKCTP*);
BEGIN (*MARK*)
FOR I := TOP DOWNTO LIM DO
MARKCTP(DISPLAY[I].FNAME)
END (*MARK*);
PROCEDURE FOLLOWCTP(FP: CTP); FORWARD;
PROCEDURE FOLLOWSTP(FP: STP);
BEGIN
IF FP <> NIL THEN
WITH FP↑ DO
IF MARKED THEN
BEGIN MARKED := FALSE; WRITE(OUTPUT,' ':4,ORD(FP):6,SIZE:10);
CASE FORM OF
SCALAR: BEGIN WRITE(OUTPUT,'SCALAR':10);
IF SCALKIND = STANDARD THEN
WRITE(OUTPUT,'STANDARD ':10)
ELSE WRITE(OUTPUT,'DECLARED ':10, ORD(FCONST):8);
WRITELN(OUTPUT)
END;
SUBRANGE:BEGIN
WRITE(OUTPUT,'SUBRANGE ':10,' ':4,ORD(RANGETYPE):6);
IF RANGETYPE <> REALPTR THEN
WRITE(OUTPUT,MIN.IVAL,MAX.IVAL)
ELSE
IF (MIN.VALP <> NIL) AND (MAX.VALP <> NIL) THEN
WRITE(OUTPUT,' ',MIN.VALP↑.RVAL:9,
' ',MAX.VALP↑.RVAL:9);
WRITELN(OUTPUT); FOLLOWSTP(RANGETYPE);
END;
POINTER: WRITELN(OUTPUT,'POINTER':10,' ':4,ORD(ELTYPE):6);
POWER: BEGIN WRITELN(OUTPUT,'SET':10,' ':4,ORD(ELSET):6);
FOLLOWSTP(ELSET)
END;
ARRAYS: BEGIN
WRITELN(OUTPUT,'ARRAY':10,' ':4,ORD(AELTYPE):6,' ':4,
ORD(INXTYPE):6);
FOLLOWSTP(AELTYPE); FOLLOWSTP(INXTYPE)
END;
RECORDS: BEGIN
WRITELN(OUTPUT,'RECORD':10,' ':4,ORD(FSTFLD):6,' ':4,
ORD(RECVAR):6); FOLLOWCTP(FSTFLD);
FOLLOWSTP(RECVAR)
END;
FILES: BEGIN WRITE(OUTPUT,'FILE':10,' ':4,ORD(FILTYPE):6);
FOLLOWSTP(FILTYPE)
END;
TAGFLD: BEGIN WRITELN(OUTPUT,'TAGFLD':10,' ':4,ORD(TAGFIELDP):6,
' ':4,ORD(FSTVAR):6);
FOLLOWSTP(FSTVAR)
END;
VARIANT: BEGIN WRITELN(OUTPUT,'VARIANT':10,' ':4,ORD(NXTVAR):6,
' ':4,ORD(SUBVAR):6,VARVAL.IVAL);
FOLLOWSTP(NXTVAR); FOLLOWSTP(SUBVAR)
END
END (*CASE*)
END (*IF MARKED*)
END (*FOLLOWSTP*);
(** FOLLOWCTP GENLABEL PRNTSYMBL PRNTVAR PRNTTYPE PRNTVAR **)
PROCEDURE FOLLOWCTP;
VAR I: INTEGER;
BEGIN
IF FP <> NIL THEN
WITH FP↑ DO
BEGIN WRITE(OUTPUT,' ':4,ORD(FP):6,' ',NAME:9,' ':4,ORD(LLINK):6,
' ':4,ORD(RLINK):6,' ':4,ORD(IDTYPE):6);
CASE KLASS OF
TYPES: WRITE(OUTPUT,'TYPE':10);
KONST: BEGIN WRITE(OUTPUT,'CONSTANT ':10,' ':4,ORD(NEXT):6);
IF IDTYPE <> NIL THEN
IF IDTYPE = REALPTR THEN
BEGIN
IF VALUES.VALP <> NIL THEN
WRITE(OUTPUT,' ',VALUES.VALP↑.RVAL:9)
END
ELSE
IF IDTYPE↑.FORM = ARRAYS THEN (*STRINGCONST*)
BEGIN
IF VALUES.VALP <> NIL THEN
BEGIN WRITE(OUTPUT,' ');
WITH VALUES.VALP↑ DO
FOR I := 1 TO SLNGTH DO
WRITE(OUTPUT,SVAL[I])
END
END
ELSE WRITE(OUTPUT,VALUES.IVAL)
END;
VARS: BEGIN WRITE(OUTPUT,'VARIABLE ':10);
IF VKIND = ACTUAL THEN WRITE(OUTPUT,'ACTUAL':10)
ELSE WRITE(OUTPUT,'FORMAL':10);
WRITE(OUTPUT,' ':4,ORD(NEXT):6,VLEV,' ':4,VADDR:6 );
END;
FIELD: WRITE(OUTPUT,'FIELD':10,' ':4,ORD(NEXT):6,' ':4,FLDADDR:6);
PROC,
FUNC: BEGIN
IF KLASS = PROC THEN WRITE(OUTPUT,'PROCEDURE':10)
ELSE WRITE(OUTPUT,'FUNCTION ':10);
IF PFDECKIND = STANDARD THEN
WRITE(OUTPUT,'STANDARD ':10,
KEY:10)
ELSE
BEGIN WRITE(OUTPUT,'DECLARED ':10, ORD(NEXT):8);
WRITE(OUTPUT,PFLEV,' ':4,PFNAME:6);
IF PFKIND = ACTUAL THEN
BEGIN WRITE(OUTPUT,'ACTUAL':10);
IF FWDECL THEN WRITE(OUTPUT,'FORWARD':10)
ELSE WRITE(OUTPUT,'NOTFORWARD':10);
IF EXTRN THEN WRITE(OUTPUT,'EXTRN':10)
ELSE WRITE(OUTPUT,'NOT EXTRN':10);
END
ELSE WRITE(OUTPUT,'FORMAL':10)
END
END
END (*CASE*);
WRITELN(OUTPUT); FOLLOWCTP(LLINK); FOLLOWCTP(RLINK);
FOLLOWSTP(IDTYPE)
END (*WITH*)
END (*FOLLOWCTP*);
BEGIN (*PRINTTABLES*)
WRITELN(OUTPUT); WRITELN(OUTPUT); WRITELN(OUTPUT);
IF FB THEN LIM := 0
ELSE BEGIN LIM := TOP; WRITE(OUTPUT,' LOCAL') END;
WRITELN(OUTPUT,' TABLES '); WRITELN(OUTPUT);
MARKER;
FOR I := TOP DOWNTO LIM DO
FOLLOWCTP(DISPLAY[I].FNAME);
WRITELN(OUTPUT);
IF NOT EOL THEN WRITE(OUTPUT,' ':CHCNT+16)
END (*PRINTTABLES*); "
PROCEDURE GENLABEL(VAR NXTLAB: INTEGER);
BEGIN INTLABEL := INTLABEL + 1;
NXTLAB := INTLABEL
END (*GENLABEL*);
(* THE FOLLOWING WRITES ENTRIES INTO SYMTBL FOR USE BY DUMP PROGRAM *)
"E"
PROCEDURE PRNTSYMBL(LCP:CTP);
VAR LINELN:INTEGER; (* CURRENT OUTPUT LINE LENGTH *)
PROCEDURE PRNTVAR(VRP:CTP; VAR LINELN:INTEGER); FORWARD;
PROCEDURE PRNTTYPE(TYPP:STP; VAR LINELN:INTEGER);
VAR VP:CTP;
BEGIN
IF (LINELN+3) >= 80 THEN BEGIN WRITELN(SYMTBL);
WRITE(SYMTBL,' '); LINELN := 0; END
ELSE LINELN := LINELN+3;
IF TYPP=INTPTR THEN WRITE(SYMTBL,'I; ')
ELSE IF TYPP=REALPTR THEN WRITE(SYMTBL,'R; ')
ELSE IF TYPP=BOOLPTR THEN WRITE(SYMTBL,'B; ')
ELSE IF TYPP=CHARPTR THEN WRITE(SYMTBL,'C; ')
ELSE CASE TYPP↑.FORM OF
SCALAR: WRITE(SYMTBL,'L; ');
POINTER: WRITE(SYMTBL,'P; ');
POWER: WRITE(SYMTBL,'S; ');
FILES: WRITE(SYMTBL,'F; ');
RECORDS: BEGIN WRITE(SYMTBL,'D ');
VP := TYPP↑.FSTFLD;
WHILE VP <> NIL DO BEGIN PRNTVAR(VP, LINELN);
VP := VP↑.NEXT; END;
IF (LINELN+2) >= 80 THEN BEGIN WRITELN(SYMTBL);
WRITE(SYMTBL,' '); LINELN := 0; END
ELSE LINELN := LINELN+2;
WRITE(SYMTBL,'; ');
END;
ARRAYS: BEGIN WRITE(SYMTBL,'A ');
IF (LINELN+26) >= 80 THEN BEGIN WRITELN(SYMTBL);
WRITE(SYMTBL,' '); LINELN := 0 END
ELSE LINELN := LINELN+26;
WRITE(SYMTBL,TYPP↑.INXTYPE↑.MIN.IVAL,' ',
TYPP↑.INXTYPE↑.MAX.IVAL,' ');
PRNTTYPE(TYPP↑.AELTYPE, LINELN);
END;
END;
END; (* PRNTTYPE *)
PROCEDURE PRNTVAR;
BEGIN
IF (LINELN+IDLNGTH+1) >= 80 THEN BEGIN WRITELN(SYMTBL);
WRITE(SYMTBL,' '); LINELN := 0; END
ELSE LINELN := LINELN+IDLNGTH+1;
WRITE(SYMTBL,VRP↑.NAME,' ');
PRNTTYPE(VRP↑.IDTYPE, LINELN);
END;
BEGIN (* PRNTSYMBL *)
CASE LCP↑.KLASS OF
VARS: BEGIN
WRITE(SYMTBL,LCP↑.VADDR,' ',LCP↑.NAME,' ');
LINELN := IDLNGTH+12;
PRNTTYPE(LCP↑.IDTYPE, LINELN);
END;
PROC,FUNC: BEGIN
WRITE(SYMTBL,'% ',LCP↑.NAME,' ',LCP↑.PFNAME);
WHILE LCP↑.NEXT <> NIL DO BEGIN
PRNTSYMBL(LCP↑.NEXT); LCP := LCP↑.NEXT; END;
END;
TYPES,KONST,FIELD: ;
END;
WRITELN(SYMTBL);
END; (* PRNTSYMBL *)
"E"
(** SET_IN BUILD_SET **)
(* SET_IN performs the function of the set IN operator for the structured
representation of large sets. Its first parameter is the scalar to be
tested for inclusion in the set, which is the second parameter. setch*)
function SET_IN(SET_EL: SET_EL_TYP; PSET: SETREP): boolean; (*setch*)
var INDEX: SETREP_INDEX;
begin
INDEX := SET_EL div HOST_SET_SIZE; (*figure which real set to use*)
SET_EL := SET_EL mod HOST_SET_SIZE; (*figure correct offset*)
if SET_EL in PSET[INDEX] then
SET_IN := true
else
SET_IN := false;
end (*SET_IN*);
procedure BUILD_SET(SET_EL: SET_EL_TYP; var S: SETREP); (*setch*)
(*Add a scalar to a structured representation of a large set.*)
var INDEX: SETREP_INDEX;
begin
INDEX := SET_EL div HOST_SET_SIZE;
SET_EL := SET_EL mod HOST_SET_SIZE;
S[INDEX] := S[INDEX]+[SET_EL];
end (*BUILD_SET*);
(** BLOCK SKIP ALIGN CONSTANT **)
PROCEDURE BLOCK(FSYS: SETOFSYS; FSY: SYMBOL; FPROCP: CTP);
# VAR LSY: SYMBOL; TEST: BOOLEAN; SEGSIZE: INTEGER ;
PROCEDURE SKIP(FSYS: SETOFSYS);
(*SKIP INPUT STRING UNTIL RELEVANT SYMBOL FOUND*)
BEGIN
WHILE NOT(SY IN FSYS) DO
BEGIN
INSYMBOL
END ;
END (*SKIP*) ;
#
# PROCEDURE ALIGN(VAR Q:ADDRRANGE; P: ADDRRANGE) ;
#
# VAR I : INTEGER ;
#
# BEGIN
# IF P >= MXDATASZE THEN P := MXDATASZE (*LCW*)
# ELSE IF P >= INTSIZE THEN P := INTSIZE
# ELSE IF P <= 0 THEN IF ERRORCOUNT = 0 THEN ERROR(500) ;
# IF P >= INTSIZE THEN
# BEGIN I:= Q MOD P ; IF I > 0 THEN Q := Q+(P-I) END ;
# END (*ALIGN*) ;
PROCEDURE CONSTANT(FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU);
VAR LSP: STP; LCP: CTP; SIGN: (NONE,POS,NEG);
LVP: CSP; I: 2..REALLNGTH;
BEGIN LSP := NIL; FVALU.IVAL := 0;
IF NOT(SY IN CONSTBEGSYS) THEN
BEGIN ERROR(50); SKIP(FSYS+CONSTBEGSYS) END;
IF SY IN CONSTBEGSYS THEN
BEGIN
IF SY = STRINGCONST THEN
BEGIN
IF LNGTH = 1 THEN LSP := CHARPTR
ELSE
BEGIN
NEW(LSP,ARRAYS);
WITH LSP↑ DO
BEGIN AELTYPE := CHARPTR; INXTYPE := NIL;
SIZE := LNGTH*CHARSIZE; FORM := ARRAYS
END
END;
FVALU := VAL; INSYMBOL
END
ELSE
BEGIN
SIGN := NONE;
IF (SY = ADDOP) AND (OP IN [PLUS,MINUS]) THEN
BEGIN IF OP = PLUS THEN SIGN := POS ELSE SIGN := NEG;
INSYMBOL
END;
IF SY = IDENT THEN
BEGIN SEARCHID([KONST],LCP);
WITH LCP↑ DO
BEGIN LSP := IDTYPE; FVALU := VALUES END;
IF SIGN <> NONE THEN
IF LSP = INTPTR THEN
BEGIN IF SIGN = NEG THEN FVALU.IVAL := -FVALU.IVAL END
ELSE
IF LSP = REALPTR THEN
BEGIN
IF SIGN = NEG THEN
BEGIN NEW(LVP,REEL);
IF FVALU.VALP↑.RVAL[1] = '-' THEN
LVP↑.RVAL[1] := '+'
ELSE LVP↑.RVAL[1] := '-';
FOR I := 2 TO REALLNGTH DO
LVP↑.RVAL[I] := FVALU.VALP↑.RVAL[I];
FVALU.VALP := LVP;
END
END
ELSE ERROR(105);
INSYMBOL;
END
ELSE
IF SY = INTCONST THEN
BEGIN IF SIGN = NEG THEN VAL.IVAL := -VAL.IVAL;
LSP := INTPTR; FVALU := VAL; INSYMBOL
END
ELSE
IF SY = REALCONST THEN
BEGIN IF SIGN = NEG THEN VAL.VALP↑.RVAL[1] := '-';
LSP := REALPTR; FVALU := VAL; INSYMBOL
END
ELSE
BEGIN ERROR(106); SKIP(FSYS) END
END;
IF NOT (SY IN FSYS) THEN
BEGIN ERROR(6); SKIP(FSYS) END
END;
FSP := LSP
END (*CONSTANT*) ;
(** COMPTYPES STRING **)
FUNCTION COMPTYPES(FSP1,FSP2: STP) : BOOLEAN;
(*DECIDE WHETHER STRUCTURES POINTED AT BY FSP1 AND FSP2 ARE COMPATIBLE*)
VAR NXT1,NXT2: CTP; COMP: BOOLEAN;
LTESTP1,LTESTP2 : TESTP;
BEGIN
IF FSP1 = FSP2 THEN COMPTYPES := TRUE
ELSE
IF (FSP1 <> NIL) AND (FSP2 <> NIL) THEN
IF FSP1↑.FORM = FSP2↑.FORM THEN
CASE FSP1↑.FORM OF
SCALAR:
COMPTYPES := FALSE;
(* IDENTICAL SCALARS DECLARED ON DIFFERENT LEVELS ARE
NOT RECOGNIZED TO BE COMPATIBLE*)
SUBRANGE:
COMPTYPES := COMPTYPES(FSP1↑.RANGETYPE,FSP2↑.RANGETYPE);
POINTER:
BEGIN
COMP := FALSE; LTESTP1 := GLOBTESTP;
LTESTP2 := GLOBTESTP;
WHILE LTESTP1 <> NIL DO
WITH LTESTP1↑ DO
BEGIN
IF (ELT1 = FSP1↑.ELTYPE) AND
(ELT2 = FSP2↑.ELTYPE) THEN COMP := TRUE;
LTESTP1 := LASTTESTP
END;
IF NOT COMP THEN
BEGIN NEW(LTESTP1);
WITH LTESTP1↑ DO
BEGIN ELT1 := FSP1↑.ELTYPE;
ELT2 := FSP2↑.ELTYPE;
LASTTESTP := GLOBTESTP
END;
GLOBTESTP := LTESTP1;
COMP := COMPTYPES(FSP1↑.ELTYPE,FSP2↑.ELTYPE)
END;
COMPTYPES := COMP; GLOBTESTP := LTESTP2
END;
POWER:
COMPTYPES := COMPTYPES(FSP1↑.ELSET,FSP2↑.ELSET);
ARRAYS:
COMPTYPES := COMPTYPES(FSP1↑.AELTYPE,FSP2↑.AELTYPE)
AND (FSP1↑.SIZE = FSP2↑.SIZE);
(*ALTERNATIVES: -- ADD A THIRD BOOLEAN TERM: INDEXTYPE MUST
BE COMPATIBLE.
-- ADD A FOURTH BOOLEAN TERM: LOWBOUNDS MUST
BE THE SAME*)
RECORDS:
BEGIN NXT1 := FSP1↑.FSTFLD; NXT2 := FSP2↑.FSTFLD; COMP:=TRUE;
WHILE (NXT1 <> NIL) AND (NXT2 <> NIL) DO
BEGIN COMP:=COMP AND COMPTYPES(NXT1↑.IDTYPE,NXT2↑.IDTYPE);
NXT1 := NXT1↑.NEXT; NXT2 := NXT2↑.NEXT
END;
COMPTYPES := COMP AND (NXT1 = NIL) AND (NXT2 = NIL)
AND(FSP1↑.RECVAR = NIL)AND(FSP2↑.RECVAR = NIL)
END;
(*IDENTICAL RECORDS ARE RECOGNIZED TO BE COMPATIBLE
IFF NO VARIANTS OCCUR*)
FILES:
COMPTYPES := COMPTYPES(FSP1↑.FILTYPE,FSP2↑.FILTYPE)
END (*CASE*)
ELSE (*FSP1↑.FORM <> FSP2↑.FORM*)
IF FSP1↑.FORM = SUBRANGE THEN
COMPTYPES := COMPTYPES(FSP1↑.RANGETYPE,FSP2)
ELSE
IF FSP2↑.FORM = SUBRANGE THEN
COMPTYPES := COMPTYPES(FSP1,FSP2↑.RANGETYPE)
ELSE COMPTYPES := FALSE
ELSE COMPTYPES := TRUE
END (*COMPTYPES*) ;
FUNCTION STRING(FSP: STP) : BOOLEAN;
BEGIN STRING := FALSE;
IF FSP <> NIL THEN
IF FSP↑.FORM = ARRAYS THEN
# STRING := COMPTYPES(FSP↑.AELTYPE,CHARPTR)
END (*STRING*) ;
(** TYP SIMPLETYPE **)
PROCEDURE TYP(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE);
VAR LSP,LSP1,LSP2: STP; OLDTOP: DISPRANGE; LCP: CTP;
LSIZE,DISPL: ADDRRANGE; LMIN,LMAX: INTEGER; ALNFCT : 1..8 ;
PROCEDURE SIMPLETYPE(FSYS:SETOFSYS; VAR FSP:STP"; VAR FSIZE:ADDRRANGE");
VAR LSP,LSP1: STP; LCP,LCP1: CTP; TTOP: DISPRANGE;
LCNT: INTEGER; LVALU: VALU;
BEGIN FSIZE := 1;
IF NOT (SY IN SIMPTYPEBEGSYS) THEN
BEGIN ERROR(1); SKIP(FSYS + SIMPTYPEBEGSYS) END;
IF SY IN SIMPTYPEBEGSYS THEN
BEGIN
IF SY = LPARENT THEN
BEGIN TTOP := TOP; (*DECL. CONSTS LOCAL TO INNERMOST BLOCK*)
WHILE DISPLAY[TOP].OCCUR <> BLCK DO TOP := TOP - 1;
NEW(LSP,SCALAR,DECLARED);
WITH LSP↑ DO
BEGIN SIZE := INTSIZE; FORM := SCALAR;
SCALKIND := DECLARED
END;
LCP1 := NIL; LCNT := 0;
REPEAT INSYMBOL;
IF SY = IDENT THEN
BEGIN NEW(LCP,KONST);
WITH LCP↑ DO
BEGIN NAME := ID; IDTYPE := LSP; NEXT := LCP1;
VALUES.IVAL := LCNT; KLASS := KONST
END;
ENTERID(LCP);
LCNT := LCNT + 1;
LCP1 := LCP; INSYMBOL
END
ELSE ERROR(2);
IF NOT (SY IN FSYS + [COMMA,RPARENT]) THEN
BEGIN ERROR(6); SKIP(FSYS + [COMMA,RPARENT]) END
UNTIL SY <> COMMA;
# IF PACKDATA THEN
# IF LCNT < 256 THEN LSP↑.SIZE := CHARSIZE ;
# LSP↑.ALN := LSP↑.SIZE ;
LSP↑.FCONST := LCP1; TOP := TTOP;
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END
ELSE
BEGIN
IF SY = IDENT THEN
BEGIN SEARCHID([TYPES,KONST],LCP);
INSYMBOL;
IF LCP↑.KLASS = KONST THEN
BEGIN NEW(LSP,SUBRANGE);
WITH LSP↑, LCP↑ DO
BEGIN RANGETYPE := IDTYPE; FORM := SUBRANGE;
IF STRING(RANGETYPE) THEN
BEGIN ERROR(148); RANGETYPE := NIL END;
# MIN := VALUES; SIZE := IDTYPE↑.SIZE
END;
## # IF SY = DOTDOT THEN INSYMBOL ELSE ERROR(5);
CONSTANT(FSYS,LSP1,LVALU);
LSP↑.MAX := LVALU;
# IF PACKDATA THEN
# IF LVALU.IVAL < 256 THEN
# IF LSP↑.MIN.IVAL >= 0 THEN LSP↑.SIZE := CHARSIZE ;
# LSP↑.ALN := LSP↑.SIZE ;
IF LSP↑.RANGETYPE <> LSP1 THEN ERROR(107)
END
ELSE
BEGIN LSP := LCP↑.IDTYPE;
# " IF LSP <> NIL THEN FSIZE := LSP↑.SIZE "
END
END (*SY = IDENT*)
ELSE
BEGIN NEW(LSP,SUBRANGE); LSP↑.FORM := SUBRANGE;
CONSTANT(FSYS + [DOTDOT],LSP1,LVALU);
IF STRING(LSP1) THEN
BEGIN ERROR(148); LSP1 := NIL END;
WITH LSP↑ DO
# BEGIN RANGETYPE:=LSP1; MIN:=LVALU; SIZE:=INTSIZE;
# IF LSP1 <> NIL THEN SIZE := LSP1↑.SIZE ;
# END;
## # IF SY = DOTDOT THEN INSYMBOL ELSE ERROR(5);
CONSTANT(FSYS,LSP1,LVALU);
LSP↑.MAX := LVALU;
# IF PACKDATA THEN
# IF LVALU.IVAL < 256 THEN
# IF LSP↑.MIN.IVAL >= 0 THEN LSP↑.SIZE := CHARSIZE ;
# LSP↑.ALN := LSP↑.SIZE ;
IF LSP↑.RANGETYPE <> LSP1 THEN ERROR(107)
END;
IF LSP <> NIL THEN
WITH LSP↑ DO
IF FORM = SUBRANGE THEN
IF RANGETYPE <> NIL THEN
IF RANGETYPE = REALPTR THEN ERROR(398)
ELSE
IF MIN.IVAL > MAX.IVAL THEN ERROR(102)
END;
FSP := LSP;
IF NOT (SY IN FSYS) THEN
BEGIN ERROR(6); SKIP(FSYS) END
END
ELSE FSP := NIL
END (*SIMPLETYPE*) ;
(** FIELDLIST **)
PROCEDURE FIELDLIST(FSYS: SETOFSYS; VAR FRECVAR: STP;VAR RECALN: ALNRNG);
VAR LCP,LCP1,NXT,NXT1: CTP; LSP,LSP1,LSP2,LSP3,LSP4: STP;
# MINSIZE,MAXSIZE,LSIZE: ADDRRANGE; LVALU: VALU; LALNFCT : ALNRNG ;
# BEGIN NXT1 := NIL; LSP := NIL; RECALN := 1 ;
IF NOT (SY IN FSYS+[IDENT,CASESY]) THEN
BEGIN ERROR(19); SKIP(FSYS + [IDENT,CASESY]) END;
WHILE SY = IDENT DO
BEGIN NXT := NXT1;
REPEAT
IF SY = IDENT THEN
BEGIN NEW(LCP,FIELD);
WITH LCP↑ DO
BEGIN NAME := ID; IDTYPE := NIL; NEXT := NXT;
KLASS := FIELD
END;
NXT := LCP;
ENTERID(LCP);
INSYMBOL
END
ELSE ERROR(2);
IF NOT (SY IN [COMMA,COLON]) THEN
BEGIN ERROR(6); SKIP(FSYS + [COMMA,COLON,SEMICOLON,CASESY])
END;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
TYP(FSYS + [CASESY,SEMICOLON],LSP,LSIZE);
# LALNFCT := 1 ; IF LSP <> NIL THEN LALNFCT := LSP↑.ALN ;
WHILE NXT <> NXT1 DO
WITH NXT↑ DO
# BEGIN IDTYPE := LSP; ALIGN(DISPL,LALNFCT) ; FLDADDR := DISPL;
NXT := NEXT; DISPL := DISPL + LSIZE
END;
# IF LALNFCT > RECALN THEN RECALN := LSP↑.ALN ;
NXT1 := LCP;
IF SY = SEMICOLON THEN
BEGIN INSYMBOL;
# IF NOT (SY IN [IDENT,CASESY,ENDSY]) THEN (* IGNOR EXTRA ; *)
BEGIN ERROR(19); SKIP(FSYS + [IDENT,CASESY]) END
END
END (*WHILE*);
NXT := NIL;
WHILE NXT1 <> NIL DO
WITH NXT1↑ DO
BEGIN LCP := NEXT; NEXT := NXT; NXT := NXT1; NXT1 := LCP END;
IF SY = CASESY THEN
BEGIN NEW(LSP,TAGFLD);
WITH LSP↑ DO
BEGIN TAGFIELDP := NIL; FSTVAR := NIL; FORM:=TAGFLD END;
FRECVAR := LSP;
INSYMBOL;
IF SY = IDENT THEN
BEGIN NEW(LCP,FIELD);
WITH LCP↑ DO
BEGIN NAME := ID; IDTYPE := NIL; KLASS:=FIELD;
# NEXT := NIL ; (*FLDADDR WILL BE SET WHEN TYPE IS KNOWN*)
END;
"TAG" PRTERR := FALSE ; SEARCHID([TYPES],LCP1) ; PRTERR := TRUE ;
"TAG" IF LCP1 = NIL THEN BEGIN (*EXPLICIT TAG FIELD *)
# ENTERID(LCP); INSYMBOL ;
# IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
# IF SY <> IDENT THEN
# BEGIN ERROR(2); SKIP(FSYS + [OFSY,LPARENT]) END
"TAG" ; END (* IF LCP1 = NIL *)
# ELSE (* NO EXPLICT TAG FIELD *)
"TAG" LCP↑.NAME := BLANK12 ;
BEGIN SEARCHID([TYPES],LCP1);
LSP1 := LCP1↑.IDTYPE;
IF LSP1 <> NIL THEN
WITH LSP1↑ DO
# BEGIN
"TAG" IF LCP↑.NAME <> BLANK12 THEN BEGIN
# ALIGN(DISPL,ALN) ;
# IF ALN > RECALN THEN RECALN := ALN ;
# LCP↑.FLDADDR := DISPL ; DISPL := DISPL + SIZE;
"TAG" END (* LCP↑.NAME <> BLANK12 *) ;
IF (FORM <= SUBRANGE) OR STRING(LSP1) THEN
BEGIN IF COMPTYPES(REALPTR,LSP1) THEN ERROR(109)
ELSE IF STRING(LSP1) THEN ERROR(398);
LCP↑.IDTYPE := LSP1; LSP↑.TAGFIELDP := LCP;
END
ELSE ERROR(110);
END (* WITH LSP1↑ DO *) ;
INSYMBOL;
END
END
ELSE BEGIN ERROR(2); SKIP(FSYS + [OFSY,LPARENT]) END;
# LSP↑.SIZE := DISPL;
IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL;
REPEAT LSP2 := NIL;
REPEAT CONSTANT(FSYS + [COMMA,COLON,LPARENT],LSP3,LVALU);
IF LSP↑.TAGFIELDP <> NIL THEN
IF NOT COMPTYPES(LSP↑.TAGFIELDP↑.IDTYPE,LSP3)THEN ERROR(111);
NEW(LSP3,VARIANT);
WITH LSP3↑ DO
BEGIN NXTVAR := LSP1; SUBVAR := LSP2; VARVAL := LVALU;
FORM := VARIANT
END;
LSP1 := LSP3; LSP2 := LSP3;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9);
FIELDLIST(FSYS + [RPARENT,SEMICOLON],LSP2,LALNFCT);
# IF LALNFCT > RECALN THEN RECALN := LALNFCT ;
IF DISPL > MAXSIZE THEN MAXSIZE := DISPL;
WHILE LSP3 <> NIL DO
BEGIN LSP4 := LSP3↑.SUBVAR; LSP3↑.SUBVAR := LSP2;
LSP3↑.SIZE := DISPL;
LSP3 := LSP4
END;
IF SY = RPARENT THEN
BEGIN INSYMBOL;
IF NOT (SY IN FSYS + [SEMICOLON]) THEN
BEGIN ERROR(6); SKIP(FSYS + [SEMICOLON]) END
END
ELSE ERROR(4);
TEST := SY <> SEMICOLON;
IF NOT TEST THEN
BEGIN DISPL := MINSIZE;
# INSYMBOL ; TEST := SY = ENDSY ; (* IGNORE EXTRA ;*)
END
UNTIL TEST;
DISPL := MAXSIZE;
LSP↑.FSTVAR := LSP1;
END
ELSE FRECVAR := NIL
END (*FIELDLIST*) ;
BEGIN (*TYP*)
IF NOT (SY IN TYPEBEGSYS) THEN
BEGIN ERROR(10); SKIP(FSYS + TYPEBEGSYS) END;
IF SY IN TYPEBEGSYS THEN
BEGIN
IF SY IN SIMPTYPEBEGSYS THEN SIMPLETYPE(FSYS,FSP",FSIZE")
ELSE
(*↑*) IF SY = ARROW THEN
BEGIN NEW(LSP,POINTER); FSP := LSP;
WITH LSP↑ DO
BEGIN ELTYPE := NIL;
# SIZE := PTRSIZE; ALN := PTRSIZE ; FORM:=POINTER
END;
INSYMBOL;
IF SY = IDENT THEN
BEGIN PRTERR := FALSE; (*NO ERROR IF SEARCH NOT SUCCESSFUL*)
SEARCHID([TYPES],LCP); PRTERR := TRUE;
IF LCP = NIL THEN (*FORWARD REFERENCED TYPE ID*)
BEGIN NEW(LCP,TYPES);
WITH LCP↑ DO
BEGIN NAME := ID; IDTYPE := LSP;
NEXT := FWPTR; KLASS := TYPES
END;
FWPTR := LCP
END
ELSE
BEGIN
IF LCP↑.IDTYPE <> NIL THEN
IF LCP↑.IDTYPE↑.FORM = FILES THEN ERROR(108)
ELSE LSP↑.ELTYPE := LCP↑.IDTYPE
END;
INSYMBOL;
END
ELSE ERROR(2);
END
ELSE
BEGIN
IF SY = PACKEDSY THEN
BEGIN INSYMBOL;
IF NOT (SY IN TYPEDELS) THEN
BEGIN
ERROR(10); SKIP(FSYS + TYPEDELS)
END
END;
(*ARRAY*) IF SY = ARRAYSY THEN
BEGIN INSYMBOL;
IF SY = LBRACK THEN INSYMBOL ELSE ERROR(11);
LSP1 := NIL;
REPEAT NEW(LSP,ARRAYS);
WITH LSP↑ DO
BEGIN AELTYPE := LSP1; INXTYPE := NIL; FORM:=ARRAYS END;
LSP1 := LSP;
SIMPLETYPE(FSYS + [COMMA,RBRACK,OFSY],LSP2",LSIZE");
# " LSP1↑.SIZE := LSIZE ; NOT USED "
IF LSP2 <> NIL THEN
IF LSP2↑.FORM <= SUBRANGE THEN
BEGIN
IF LSP2 = REALPTR THEN
BEGIN ERROR(109); LSP2 := NIL END
ELSE
IF LSP2 = INTPTR THEN
BEGIN ERROR(149); LSP2 := NIL END;
LSP↑.INXTYPE := LSP2
END
ELSE BEGIN ERROR(113); LSP2 := NIL END;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12);
IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
# TYP(FSYS,LSP,LSIZE); ALIGN(LSIZE,LSP↑.ALN) ;
REPEAT
WITH LSP1↑ DO
BEGIN LSP2 := AELTYPE; AELTYPE := LSP;
IF INXTYPE <> NIL THEN
BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX);
LSIZE := LSIZE*(LMAX - LMIN + 1);
SIZE := LSIZE ; ALN := LSP↑.ALN (*PROPAG. ALN*) ;
END
END;
LSP := LSP1; LSP1 := LSP2
UNTIL LSP1 = NIL
END
ELSE
(*RECORD*) IF SY = RECORDSY THEN
BEGIN INSYMBOL;
OLDTOP := TOP;
IF TOP < DISPLIMIT THEN
BEGIN TOP := TOP + 1;
WITH DISPLAY[TOP] DO
BEGIN FNAME := NIL;
FLABEL := NIL;
OCCUR := REC
END
END
ELSE ERROR(250);
DISPL := 0;
FIELDLIST(FSYS-[SEMICOLON]+[ENDSY],LSP1,ALNFCT);
NEW(LSP,RECORDS);
WITH LSP↑ DO
BEGIN FSTFLD := DISPLAY[TOP].FNAME;
RECVAR := LSP1; SIZE := DISPL;
FORM := RECORDS ; ALN := ALNFCT ;
END;
TOP := OLDTOP;
IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13)
END
ELSE
(*SET*) IF SY = SETSY THEN
BEGIN INSYMBOL;
IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
SIMPLETYPE(FSYS,LSP1",LSIZE");
IF LSP1 <> NIL THEN
IF LSP1↑.FORM > SUBRANGE THEN
BEGIN ERROR(115); LSP1 := NIL END
ELSE
IF LSP1 = REALPTR THEN ERROR(114)
## ELSE IF LSP1↑.FORM = SUBRANGE THEN
## IF LSP1↑.MAX.IVAL > MAXSETEL THEN ERROR(304);
NEW(LSP,POWER);
WITH LSP↑ DO
BEGIN ELSET:=LSP1;
SIZE:=SETSIZE; ALN := INTSIZE ; FORM:=POWER
END;
END
ELSE
(*FILE*) IF SY = FILESY THEN
# "BEGIN ERROR(398); INSYMBOL; SKIP(FSYS); LSP:= NIL END;"
## BEGIN INSYMBOL ;
## IF SY = OFSY THEN INSYMBOL ELSE ERROR(8) ;
## SIMPLETYPE(FSYS,LSP1",LSIZE") ;
## IF LSP1 = NIL THEN ERROR(398)
## ELSE IF LSP1 <> CHARPTR THEN ERROR(398) ;
## LSP := TEXTPTR ;
## END ;
FSP := LSP
END;
IF NOT (SY IN FSYS) THEN
BEGIN ERROR(6); SKIP(FSYS) END
END
ELSE FSP := NIL;
IF FSP = NIL THEN FSIZE := 1 ELSE FSIZE := FSP↑.SIZE
END (*TYP*) ;
(** LABELDECLARATION CONSTDECLARATION TYPEDECLARATION **)
PROCEDURE LABELDECLARATION;
VAR LLP: LBP; REDEF: BOOLEAN; LBNAME: LABELRNG ;
BEGIN
REPEAT
IF SY = INTCONST THEN
WITH DISPLAY[TOP] DO
BEGIN LLP := FLABEL; REDEF := FALSE;
WHILE (LLP <> NIL) AND NOT REDEF DO
IF LLP↑.LABVAL <> VAL.IVAL THEN
LLP := LLP↑.NEXTLAB
ELSE BEGIN REDEF := TRUE; ERROR(166) END;
IF NOT REDEF THEN
BEGIN NEW(LLP);
WITH LLP↑ DO
BEGIN LABVAL := VAL.IVAL; GENLABEL(LBNAME);
DEFINED := FALSE; NEXTLAB := FLABEL; LABNAME := LBNAME
END;
FLABEL := LLP
END;
INSYMBOL
END
ELSE ERROR(15);
IF NOT ( SY IN FSYS + [COMMA, SEMICOLON] ) THEN
BEGIN ERROR(6); SKIP(FSYS+[COMMA,SEMICOLON]) END;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14)
END (* LABELDECLARATION *) ;
PROCEDURE CONSTDECLARATION;
VAR LCP: CTP; LSP: STP; LVALU: VALU;
BEGIN
IF SY <> IDENT THEN
BEGIN ERROR(2); SKIP(FSYS + [IDENT]) END;
WHILE SY = IDENT DO
BEGIN NEW(LCP,KONST);
WITH LCP↑ DO
BEGIN NAME := ID; IDTYPE := NIL; NEXT := NIL; KLASS:=KONST END;
INSYMBOL;
IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16);
CONSTANT(FSYS + [SEMICOLON],LSP,LVALU);
ENTERID(LCP);
LCP↑.IDTYPE := LSP; LCP↑.VALUES := LVALU;
IF SY = SEMICOLON THEN
BEGIN INSYMBOL;
IF NOT (SY IN FSYS + [IDENT]) THEN
BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END
END
ELSE ERROR(14)
END
END (*CONSTDECLARATION*) ;
PROCEDURE TYPEDECLARATION;
VAR LCP,LCP1,LCP2: CTP; LSP: STP; LSIZE: ADDRRANGE;
BEGIN
IF SY <> IDENT THEN
BEGIN ERROR(2); SKIP(FSYS + [IDENT]) END;
WHILE SY = IDENT DO
BEGIN NEW(LCP,TYPES);
WITH LCP↑ DO
BEGIN NAME := ID; IDTYPE := NIL; KLASS := TYPES END;
INSYMBOL;
IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16);
TYP(FSYS + [SEMICOLON],LSP,LSIZE);
ENTERID(LCP);
LCP↑.IDTYPE := LSP;
(*HAS ANY FORWARD REFERENCE BEEN SATISFIED:*)
LCP1 := FWPTR;
WHILE LCP1 <> NIL DO
BEGIN
IF LCP1↑.NAME = LCP↑.NAME THEN
BEGIN LCP1↑.IDTYPE↑.ELTYPE := LCP↑.IDTYPE;
IF LCP1 <> FWPTR THEN
LCP2↑.NEXT := LCP1↑.NEXT
ELSE FWPTR := LCP1↑.NEXT;
END;
LCP2 := LCP1; LCP1 := LCP1↑.NEXT
END;
IF SY = SEMICOLON THEN
BEGIN INSYMBOL;
IF NOT (SY IN FSYS + [IDENT]) THEN
BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END
END
ELSE ERROR(14)
END;
IF FWPTR <> NIL THEN
BEGIN ERROR(117); WRITELN(OUTPUT);
REPEAT WRITELN(OUTPUT,' TQPE-ID ',FWPTR↑.NAME);
FWPTR := FWPTR↑.NEXT
UFTIL FWPTR = NIL;
IF NOT EOL THEN WRITE(OUTPUT,' ': CHCNT+16)
END
END (*TYPEDECLARATION*) ;
(** VARDECLARATION **)
PROCEDURE VARDECLARATION;
# VAR LCP,NXT: CTP; LSP: STP; LSIZE: ADDRRANGE; COUNT: 0..100 ;
BEGIN NXT := NIL;
# REPEAT COUNT := 0 ;
REPEAT
IF SY = IDENT THEN
BEGIN NEW(LCP,VARS); COUNT := COUNT+1 ;
WITH LCP↑ DO
BEGIN NAME := ID; NEXT := NXT; KLASS := VARS;
IDTYPE := NIL; VKIND := ACTUAL; VLEV := LEVEL
END;
ENTERID(LCP);
NXT := LCP;
INSYMBOL;
END
ELSE ERROR(2);
IF NOT (SY IN FSYS + [COMMA,COLON] + TYPEDELS) THEN
BEGIN ERROR(6); SKIP(FSYS+[COMMA,COLON,SEMICOLON]+TYPEDELS) END;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
TYP(FSYS + [SEMICOLON] + TYPEDELS,LSP,LSIZE);
# IF LSP <> NIL THEN ALIGN(LC,LSP↑.ALN) ;
## IF LSP = TEXTPTR THEN
## BEGIN
## NXTFILBUF := NXTFILBUF+COUNT ; COUNT := 1 ;
## IF NXTFILBUF > LASTFILBUF THEN ERROR(258) ;
## END ;
WHILE NXT <> NIL DO
WITH NXT↑ DO
BEGIN IDTYPE := LSP;
## IF LSP = TEXTPTR THEN (* TEXT FILE DECLARATION *)
## BEGIN "EBCD := EBCDFLG ; EBCDFLG := FALSE ; "
## VADDR := NXTFILBUF-COUNT ; VLEV := 1 ; COUNT := COUNT+1 ;
## END
## ELSE (* OTHER VARIABLE DECLARATION *)
BEGIN VADDR := LC ; LC := LC+LSIZE END ;
"E" PRNTSYMBL(NXT); NXT := NEXT;
END;
IF SY = SEMICOLON THEN
BEGIN INSYMBOL;
IF NOT (SY IN FSYS + [IDENT]) THEN
BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END
END
ELSE ERROR(14)
UNTIL (SY <> IDENT) AND NOT (SY IN TYPEDELS);
IF FWPTR <> NIL THEN
BEGIN ERROR(117); WRITELN(OUTPUT);
REPEAT WRITELN(OUTPUT,' TYPE-ID ',FWPTR↑.NAME);
FWPTR := FWPTR↑.NEXT
UNTIL FWPTR = NIL;
IF NOT EOL THEN WRITE(OUTPUT,' ': CHCNT+16)
END ;
END (*VARDECLARATION*) ;
(** PROCDECLARATION PARAMETERLIST **)
PROCEDURE PROCDECLARATION(FSY: SYMBOL);
VAR OLDLEV: 0..MAXLEVEL; LSY: SYMBOL; LCP,LCP1: CTP; LSP: STP;
# # FORW: BOOLEAN; OLDTOP: DISPRANGE; PARCNT: INTEGER;
LLC,LCM: ADDRRANGE; LBNAME, OLDLABEL: INTEGER; MARKP: ↑INTEGER;
PROCEDURE PARAMETERLIST(FSY: SETOFSYS; VAR FPAR: CTP);
VAR LCP,LCP1,LCP2,LCP3: CTP; LSP: STP; LKIND: IDKIND;
LLC,LEN : ADDRRANGE; COUNT : INTEGER;
BEGIN LCP1 := NIL ;
"S1" FPRM1 := LC ; RPRM1 := 0 ; REGS_FULL := FALSE ;
IF NOT (SY IN FSY + [LPARENT]) THEN
BEGIN ERROR(7); SKIP(FSYS + FSY + [LPARENT]) END;
IF SY = LPARENT THEN
BEGIN IF FORW THEN ERROR(119);
INSYMBOL;
IF NOT (SY IN [IDENT,VARSY,PROCSY,FUNCSY]) THEN
BEGIN ERROR(7); SKIP(FSYS + [IDENT,RPARENT]) END;
WHILE SY IN [IDENT,VARSY,PROCSY,FUNCSY] DO
BEGIN
IF SY = PROCSY THEN
BEGIN ERROR(398);
REPEAT INSYMBOL;
IF SY = IDENT THEN
BEGIN NEW(LCP,PROC,DECLARED,FORMAL);
WITH LCP↑ DO
BEGIN NAME := ID; IDTYPE := NIL; NEXT := LCP1;
PFLEV := LEVEL (*BEWARE OF PARAMETER PROCEDURES*);
KLASS:=PROC;PFDECKIND:=DECLARED;PFKIND:=FORMAL
END;
ENTERID(LCP);
LCP1 := LCP; LC := LC + PTRSIZE;
INSYMBOL
END
ELSE ERROR(2);
IF NOT (SY IN FSYS + [COMMA,SEMICOLON,RPARENT]) THEN
BEGIN ERROR(7);SKIP(FSYS+[COMMA,SEMICOLON,RPARENT])END
UNTIL SY <> COMMA
END
ELSE
BEGIN
IF SY = FUNCSY THEN
BEGIN ERROR(398); LCP2 := NIL;
REPEAT INSYMBOL;
IF SY = IDENT THEN
BEGIN NEW(LCP,FUNC,DECLARED,FORMAL);
WITH LCP↑ DO
BEGIN NAME := ID; IDTYPE := NIL; NEXT := LCP2;
PFLEV := LEVEL (*BEWARE PARAM FUNCS*);
KLASS:=FUNC;PFDECKIND:=DECLARED;
PFKIND:=FORMAL
END;
ENTERID(LCP);
LCP2 := LCP; LC := LC + PTRSIZE;
INSYMBOL;
END;
IF NOT (SY IN [COMMA,COLON] + FSYS) THEN
BEGIN ERROR(7);SKIP(FSYS+[COMMA,SEMICOLON,RPARENT])
END
UNTIL SY <> COMMA;
IF SY = COLON THEN
BEGIN INSYMBOL;
IF SY = IDENT THEN
BEGIN SEARCHID([TYPES],LCP);
LSP := LCP↑.IDTYPE;
IF LSP <> NIL THEN
IF NOT(LSP↑.FORM IN[SCALAR,SUBRANGE,POINTER])
THEN BEGIN ERROR(120); LSP := NIL END;
LCP3 := LCP2;
WHILE LCP2 <> NIL DO
BEGIN LCP2↑.IDTYPE := LSP; LCP := LCP2;
LCP2 := LCP2↑.NEXT
END;
LCP↑.NEXT := LCP1; LCP1 := LCP3;
INSYMBOL
END
ELSE ERROR(2);
IF NOT (SY IN FSYS + [SEMICOLON,RPARENT]) THEN
BEGIN ERROR(7);SKIP(FSYS+[SEMICOLON,RPARENT])END
END
ELSE ERROR(5)
END
ELSE
BEGIN
IF SY = VARSY THEN
BEGIN LKIND := FORMAL; INSYMBOL END
ELSE LKIND := ACTUAL;
LCP2 := NIL;
COUNT := 0;
REPEAT
IF SY = IDENT THEN
BEGIN NEW(LCP,VARS);
WITH LCP↑ DO
BEGIN NAME:=ID; IDTYPE:=NIL; KLASS:=VARS;
VKIND := LKIND; NEXT := LCP2; VLEV := LEVEL;
END;
ENTERID(LCP);
LCP2 := LCP; COUNT := COUNT+1;
INSYMBOL;
END;
IF NOT (SY IN [COMMA,COLON] + FSYS) THEN
BEGIN ERROR(7);SKIP(FSYS+[COMMA,SEMICOLON,RPARENT])
END;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = COLON THEN
BEGIN INSYMBOL;
IF SY = IDENT THEN
BEGIN SEARCHID([TYPES],LCP); LEN := PTRSIZE ;
# LSP := LCP↑.IDTYPE;
IF LSP <> NIL THEN
# IF (LKIND=ACTUAL) THEN
# IF LSP↑.FORM <= POWER THEN LEN := LSP↑.SIZE
# ELSE IF LSP↑.FORM = FILES THEN ERROR(121) ;
"S0" " IF LSP↑.FORM = POWER THEN ALIGN(LC,4) "
"S0" " ELSE ALIGN(LC, LEN) ; "
"S1" ALIGN(LEN,MXDATASZE) ; ALIGN(LC,MXDATASZE) ;
LC := LC+COUNT*LEN ; LCP3 := LCP2 ; LLC := LC ;
WHILE LCP2 <> NIL DO
BEGIN LCP := LCP2;
WITH LCP2↑ DO
BEGIN IDTYPE := LSP; LLC := LLC-LEN;
VADDR := LLC;
"S1" IF NOT REGS_FULL THEN
"S1" IF RPRM1+LEN <= REGPRMAREA THEN
"S1" RPRM1 := RPRM1+LEN
"S1" ELSE REGS_FULL := TRUE ;
END;
LCP2 := LCP2↑.NEXT
END;
LCP↑.NEXT := LCP1; LCP1 := LCP3;
INSYMBOL
END
ELSE ERROR(2);
IF NOT (SY IN FSYS + [SEMICOLON,RPARENT]) THEN
BEGIN ERROR(7);SKIP(FSYS+[SEMICOLON,RPARENT])END
END
ELSE ERROR(5);
END;
END;
IF SY = SEMICOLON THEN
BEGIN INSYMBOL;
IF NOT (SY IN FSYS + [IDENT,VARSY,PROCSY,FUNCSY]) THEN
BEGIN ERROR(7); SKIP(FSYS + [IDENT,RPARENT]) END
END
END (*WHILE*) ;
IF SY = RPARENT THEN
BEGIN INSYMBOL;
IF NOT (SY IN FSY + FSYS) THEN
BEGIN ERROR(6); SKIP(FSY + FSYS) END
END
ELSE ERROR(4);
LCP3 := NIL;
(*REVERSE POINTERS AND RESERVE LOCAL CELLS FOR COPIES OF MULTIPLE
VALUES*)
" ALIGN(LC,MXDATASZE) ; " (*NORMALIZE STACK BEFORE ENTRING BLOCK*)
"S1" FPRM1 := LC-FPRM1 ; SPRM1 := LC ;
WHILE LCP1 <> NIL DO
WITH LCP1↑ DO
BEGIN LCP2 := NEXT; NEXT := LCP3;
" IF KLASS = VARS THEN ???"
IF IDTYPE <> NIL THEN
# IF VKIND = ACTUAL THEN
# # " IF FORT THEN ERROR(999)
# # ELSE "
# IF (IDTYPE↑.FORM > POWER) THEN
BEGIN ALIGN(LC,IDTYPE↑.ALN (*OR IDTYPE↑.SIZE*) ) ;
VADDR := LC; LC := LC + IDTYPE↑.SIZE ;
END ;
LCP3 := LCP1; LCP1 := LCP2
END;
"S1" ALIGN(LC, PTRSIZE) ; SPRM1 := LC-SPRM1 ;
FPAR := LCP3
END
ELSE
"S1" BEGIN
FPAR := NIL ;
"S1" FPRM1 := 0 ; SPRM1 := 0 ; RPRM1 := 0 ;
"S1" END ;
END (*PARAMETERLIST*) ;
BEGIN (*PROCDECLARATION*)
LLC := LC; LC := LCAFTMST; (* ADR. OF THE FIRST VAR. IN THIS PROC. *)
# LCP := UPRCPTR ; (* TO INITIALIZE LCP IN CASE ! *)
IF SY = IDENT THEN
BEGIN SEARCHSECTION(DISPLAY[TOP].FNAME,LCP); (*DECIDE WHETHER FORW.*)
IF LCP <> NIL THEN
BEGIN
IF LCP↑.KLASS = PROC THEN
FORW := LCP↑.FWDECL AND(FSY = PROCSY)AND(LCP↑.PFKIND = ACTUAL)
ELSE
IF LCP↑.KLASS = FUNC THEN
FORW:=LCP↑.FWDECL AND(FSY=FUNCSY)AND(LCP↑.PFKIND=ACTUAL)
ELSE FORW := FALSE;
IF NOT FORW THEN ERROR(160)
END
ELSE FORW := FALSE;
IF NOT FORW THEN
BEGIN
IF FSY = PROCSY THEN NEW(LCP,PROC,DECLARED,ACTUAL)
ELSE NEW(LCP,FUNC,DECLARED,ACTUAL);
WITH LCP↑ DO
# BEGIN NAME := ID; IDTYPE := NIL; SAVEFP := FALSE ;
# " EXTRN := FALSE;" PFLEV := LEVEL; PROCLAB := PROCLAB+1 ;
# PFDECKIND := DECLARED; PFKIND := ACTUAL; PFNAME := PROCLAB ;
IF FSY = PROCSY THEN KLASS := PROC
ELSE KLASS := FUNC
END;
ENTERID(LCP)
END
ELSE
BEGIN LCP1 := LCP↑.NEXT;
WHILE LCP1 <> NIL DO
BEGIN
WITH LCP1↑ DO
IF KLASS = VARS THEN
IF IDTYPE <> NIL THEN
BEGIN LCM := VADDR + IDTYPE↑.SIZE;
IF LCM > LC THEN LC := LCM
END;
LCP1 := LCP1↑.NEXT
END
END;
INSYMBOL
END
ELSE ERROR(2);
# OLDLEV := LEVEL; OLDTOP := TOP; OLDLABEL := INTLABEL ; INTLABEL := 0 ;
IF LEVEL < MAXLEVEL THEN LEVEL := LEVEL + 1 ELSE ERROR(251);
IF TOP < DISPLIMIT THEN
BEGIN TOP := TOP + 1;
WITH DISPLAY[TOP] DO
BEGIN
IF FORW THEN FNAME := LCP↑.NEXT
ELSE FNAME := NIL;
FLABEL := NIL;
OCCUR := BLCK
END
END
ELSE ERROR(250);
IF FSY = PROCSY THEN
BEGIN PARAMETERLIST([SEMICOLON],LCP1);
IF NOT FORW THEN LCP↑.NEXT := LCP1
END
ELSE
BEGIN PARAMETERLIST([SEMICOLON,COLON],LCP1);
IF NOT FORW THEN LCP↑.NEXT := LCP1;
IF SY = COLON THEN
BEGIN INSYMBOL;
IF SY = IDENT THEN
BEGIN IF FORW THEN ERROR(122);
SEARCHID([TYPES],LCP1);
LSP := LCP1↑.IDTYPE;
LCP↑.IDTYPE := LSP;
IF LSP <> NIL THEN
# BEGIN
# IF NOT (LSP↑.FORM IN [SCALAR,SUBRANGE,POINTER,POWER]) THEN
# BEGIN ERROR(120); LCP↑.IDTYPE := NIL END;
# IF LSP = REALPTR THEN
# IF SAVEFPRS THEN
# BEGIN LCP1 := LCP↑.NEXT ;
# WHILE LCP1 <> NIL DO
# BEGIN
# LCP1↑.VADDR := LCP1↑.VADDR+FPSAVEAREA ;
# LCP1 := LCP1↑.NEXT ;
# END ;
# LCP↑.SAVEFP := TRUE ; (* SET SAVE FPRS FLAG *)
# LC := LC+FPSAVEAREA ; (* ADJUST LOC. CNTR *)
# END ;
# END (* WITH LSP↑ DO *) ;
INSYMBOL
END
ELSE BEGIN ERROR(2); SKIP(FSYS + [SEMICOLON]) END
END
ELSE
IF NOT FORW THEN ERROR(123)
END;
# # WITH LCP↑ DO
# # BEGIN FWDECL := FALSE ; FRTRN := FALSE ; EXTRN := FALSE END ;
"S1"
"S1" IF NOT FORW THEN
"S1" WITH LCP↑ DO
"S1" BEGIN FPRMSZE := FPRM1 ; RPRMSZE := RPRM1 ; SPRMSZE := SPRM1 END;
"S1"
IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14);
# # IF SY IN [FORWARDSY,FRTRNSY,EXTRNSY] THEN
# # BEGIN
# # IF SY = FORWARDSY THEN
# # IF FORW THEN ERROR(161)
# # ELSE LCP↑.FWDECL := TRUE;
# # IF SY = FRTRNSY THEN
# # BEGIN LCP↑.FRTRN := TRUE ;
# # LCP1 := LCP↑.NEXT ;
# # WHILE LCP1 <> NIL DO
# # BEGIN IF LCP1↑.VKIND <> FORMAL THEN ERROR(7) ;
# # LCP1 := LCP1↑.NEXT ;
# # END ;
# # END (* SY = FRTRNSY *) ;
# # IF SY = EXTRNSY THEN LCP↑.EXTRN := TRUE ;
INSYMBOL;
IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14);
IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END
END
ELSE
BEGIN " LCP↑.FWDECL := FALSE; "
"E" PRNTSYMBL(LCP);
NEW(MARKP); (* MARK HEAP FOR BLOCK ENTRY *)
REPEAT BLOCK(FSYS,SEMICOLON,LCP);
IF SY = SEMICOLON THEN
BEGIN "IF PRTABLES THEN PRINTTABLES(FALSE);" INSYMBOL;
IF NOT (SY IN [BEGINSY,PROCSY,FUNCSY]) THEN
BEGIN ERROR(6); SKIP(FSYS) END
END
ELSE ERROR(14)
UNTIL SY IN [BEGINSY,PROCSY,FUNCSY];
(* RELEASE(MARKP);*) (* RETURN LOCAL ENTRIES ON RUNTIME HEAP *) (*X10S1*)
DISPOSE(MARKP); (* RETURN LOCAL ENTRIES ON RUNTIME HEAP *) (*X10S1*)
END;
LEVEL := OLDLEV; TOP := OLDTOP; LC := LLC; INTLABEL := OLDLABEL ;
END (*PROCDECLARATION*) ;
#
(** PROCTYPE BODY PUTIC FLDW GETTYPE **)
# FUNCTION PROCTYPE(FPROCP: CTP): INTEGER ;
#
# BEGIN PROCTYPE := ORD('P') ;
# IF FPROCP <> NIL THEN
# WITH FPROCP↑ DO
# # BEGIN IF FRTRN THEN PROCTYPE := ORD('F') ;
# IF FPROCP↑.IDTYPE <> NIL THEN
# WITH FPROCP↑ DO
# BEGIN
# IF IDTYPE↑.FORM = POWER THEN PROCTYPE := ORD('S')
# ELSE IF IDTYPE = REALPTR THEN
# IF FRTRN THEN PROCTYPE := ORD('Z')
# ELSE PROCTYPE := ORD('R')
# ELSE IF IDTYPE = BOOLPTR THEN
# IF FRTRN THEN PROCTYPE := ORD('X')
# ELSE PROCTYPE := ORD('B')
# ELSE IF IDTYPE↑.FORM = POINTER THEN
# PROCTYPE := ORD('A')
# ELSE IF "(IDTYPE = CHARPTR) OR ((IDTYPE↑.FORM = SUBRANGE)
# AND (IDTYPE↑.RANGETYPE = CHARPTR)) "
# IDTYPE↑.SIZE = 1 THEN PROCTYPE := ORD('C')
# ELSE IF FRTRN THEN PROCTYPE := ORD('Y')
# ELSE PROCTYPE := ORD('I') ;
# END
# END (*WITH FPROCP↑*) ;
# END (*PROCTYPE*) ;
#
PROCEDURE BODY(FSYS: SETOFSYS);
# CONST CIXMAX = 1000;
TYPE OPRANGE = 0..OPMAX;
###
### CALLED_PROC = RECORD
### NAME : ALPHA ;
### LVL : LEVRANGE ;
### CNT : 1..100 ;
### NXT : ↑ CALLED_PROC
### END ;
###
### VAR
### CALL_HEAD, T2_CLIST, T_CLIST : ↑ CALLED_PROC ;
### LOCAL_CALL, (* THIS PROC CALLS A LOCAL PROC *)
### " MOD_TRACE, " (* TRACE VARS BEING MODIFIED *)
### MODIFYING : BOOLEAN ; (*A PROGRAM VAR BEING MODIFIED*)
### VAR_REF, VAR_MOD : INTEGER ; (* # OF VARIABLES ACCESSED/REFERENCED*)
###
LLCP:CTP; SAVEID:ALPHA;
# CSTPTR: CSP;
(*ALLOWS REFERENCING OF NONINTEGER CONSTANTS BY AN INDEX
(INSTEAD OF A POINTER), WHICH CAN BE STORED IN THE P2-FIELD
OF THE INSTRUCTION RECORD UNTIL WRITEOUT.
--> PROCEDURE LOAD, PROCEDURE WRITEOUT*) (*NOT NEEDED IN P_COMP.*)
I, ENTNAME : INTEGER;
LCMAX,LLC1: ADDRRANGE; LCP: CTP;
# LLP: LBP; PROCNAME : ALPHA ;
"CTR" FIRSTLN : INTEGER; CTRNO : CTRRANGE;
PROCEDURE PUTIC;
# BEGIN
IF (IC MOD 10 = 0) THEN
"IF ASSEMBLE AND PRTIC THEN " WRITELN(PRR,' LOC',IC:6) ;
END;
# FUNCTION FLDW(NUM : INTEGER) : INTEGER ;
# VAR FW: 0..20 ;
# BEGIN
# FW := 0 ; IF NUM < 0 THEN FW := 1 ;
# NUM := ABS(NUM) ;
# REPEAT
# NUM := NUM DIV 10 ; FW := FW+1 ;
# UNTIL NUM = 0 ;
# FLDW := FW
# END (*FLDW*);
#
# FUNCTION GETTYPE(OPERAND: STP): INTEGER ;
# BEGIN GETTYPE := ORD('I') ; (* ASSUME INTEGER TYPE *)
# IF OPERAND = NIL THEN BEGIN IF ERRORCOUNT = 0 THEN ERROR(500) END
# ELSE
# IF OPERAND↑.FORM > POWER THEN GETTYPE := ORD('A')
# ELSE
# IF OPERAND↑.FORM = POWER THEN GETTYPE := ORD('S')
# ELSE
# IF OPERAND↑.FORM = POINTER THEN GETTYPE := ORD('A')
# ELSE
# IF OPERAND = REALPTR THEN GETTYPE := ORD('R')
# ELSE
# IF OPERAND = BOOLPTR THEN GETTYPE := ORD('B')
# ELSE
# BEGIN
# IF OPERAND↑.SIZE = CHARSIZE THEN GETTYPE := ORD('C')
# END
# END (*GETTYPE*) ;
#
(** GEN0 GEN1 GEN2 PRINT_SET_OPND **)
PROCEDURE GEN0(FOP: OPRANGE);
BEGIN
IF PRCODE THEN BEGIN PUTIC; WRITELN(PRR,MN[FOP]:4) END;
IC := IC + 1
END (*GEN0*) ;
PROCEDURE GEN1(FOP: OPRANGE; FP2: INTEGER);
VAR K: INTEGER;
BEGIN
IF PRCODE THEN
BEGIN PUTIC; WRITE(PRR,MN[FOP]:4,' '); "LCW 5AUG78"
IF FOP = 30 THEN (*CSP*) WRITELN(PRR,SNA[FP2]:4)
ELSE IF FOP = 37 THEN (*LCA*)
#"LCW 5AUG78" BEGIN WRITE(PRR,'''');
# WITH CSTPTR↑ DO
FOR K := 1 TO SLNGTH DO
# BEGIN WRITE(PRR,SVAL[K]:1);
# IF SVAL[K] = '''' THEN WRITE(PRR,'''')
END ;
WRITELN(PRR,'''')
END
ELSE IF (FOP = 26) OR (FOP = 42)
"S1" OR (FOP = 64) (*PRM*)
THEN (*STO,RET*)
"LCW 5AUG78" WRITELN(PRR,CHR(FP2):1)
"LCW 5AUG78" ELSE WRITELN(PRR,FP2:FLDW(FP2))
END;
IC := IC + 1
END (*GEN1*) ;
PROCEDURE GEN2(FOP: OPRANGE; FP1,FP2: INTEGER);
# VAR I, J, K : INTEGER; "FIRSTMEM : BOOLEAN ;"
PROCEDURE PRINT_SET_OPND(SETPTR: CSP); (*SETCH*)
BEGIN
WRITE(PRR,'S,(');
WITH SETPTR↑ DO
FOR I := 0 TO NUMOFSETOPND - 1 DO
BEGIN J := 0 ; K := MAXSETEL-I*16 ;
FOR K := K DOWNTO K-15 DO
BEGIN J := J*2 ;
IF SET_IN(K,PVAL) THEN J := J+1 ;
END ;
IF I > 0 THEN WRITE(PRR,',') ;
WRITE(PRR, J: FLDW(J) ) ;
END (* FOR I := 0 TO NUMOFSETOPND - 1 *) ;
WRITELN(PRR,')') ;
END (*PRINT_SET_OPND*);
BEGIN (*GEN2*)
IF PRCODE THEN
BEGIN PUTIC; WRITE(PRR,MN[FOP]:4,' ');
CASE FOP OF
22,23,35,39,43: (*DEC,INC,IND,LDO,SRO*)
WRITELN(PRR,CHR(FP1),',',FP2:FLDW(FP2)) ;
45,50: (*CHK,LDA*)
WRITELN(PRR,FP1:FLDW(FP1),',',FP2:FLDW(FP2));
47,48,49,52,53,55: (*EQU..NEQ*)
BEGIN WRITE(PRR,CHR(FP1));
IF FP1 = ORD('M') THEN WRITE(PRR,',',FP2:FLDW(FP2));
WRITELN(PRR)
END;
51: (*LDC*)
CASE FP1 OF
# 0: WRITELN(PRR,'C,''',CHR(FP2):1,'''') ;
1: WRITELN(PRR,'I,',FP2:FLDW(FP2));
2: BEGIN WRITE(PRR,'R,');
# WITH CSTPTR↑ DO
FOR K := 1 TO REALLNGTH DO
IF RVAL[K] <> ' ' THEN WRITE(PRR,RVAL[K]);
WRITELN(PRR)
END;
3: WRITELN(PRR,'B,',FP2:1);
4: WRITELN(PRR,'N');
5: PRINT_SET_OPND(CSTPTR);
# " FIRSTMEM := TRUE ;
# WITH CSTPTR↑ DO
FOR K := 0 TO MAXSETEL DO
# IF K IN PVAL THEN
# BEGIN
# IF FIRSTMEM THEN
# BEGIN WRITE(PRR,K:FLDW(K)) ;
# FIRSTMEM := FALSE
# END
# ELSE WRITE(PRR,',',K:FLDW(K)) ;
# END ;
WRITELN(PRR,')') "
END
END;
END;
IC := IC + 1
END (*GEN2*) ;
(** GEN3 LOAD STORE **)
# PROCEDURE GEN3(FOP: OPRANGE; FP0,FP1,FP2: INTEGER);
# BEGIN
# IF PRCODE THEN
# BEGIN PUTIC; WRITE(PRR,MN[FOP]:4);
"S1" IF FOP = 41 THEN (*MST*)
"S1" WRITE(PRR, FP0:2)
"S1" ELSE
# WRITE(PRR, CHR(FP0):2) ;
# WRITELN(PRR, ',', FP1:FLDW(FP1), ',', FP2:FLDW(FP2)) ;
# END;
# IC := IC + 1
# END (*GEN3*) ;
PROCEDURE LOAD;
BEGIN
WITH GATTR DO
IF TYPTR <> NIL THEN
BEGIN
CASE KIND OF
CST: IF (TYPTR↑.FORM = SCALAR) AND (TYPTR <> REALPTR) THEN
IF TYPTR = BOOLPTR THEN GEN2(51(*LDC*),3,CVAL.IVAL)
ELSE
IF TYPTR = CHARPTR THEN GEN2(51(*LDC*),0,CVAL.IVAL
(*CHARDIF*) +CHARDIF)
ELSE GEN2(51(*LDC*),1,CVAL.IVAL) (*INTEGER*)
ELSE
IF TYPTR = NILPTR THEN GEN2(51(*LDC*),4,0)
ELSE
# BEGIN
# CSTPTR := CVAL.VALP;
IF TYPTR = REALPTR THEN
# GEN2(51(*LDC*),2,0)
ELSE
# GEN2(51(*LDC*),5,0)
END;
VARBL: CASE ACCESS OF
DRCT: " IF VLEVEL <= 1 THEN
GEN2(39(*LDO*),GETTYPE(BTYPE),DPLMT)
# ELSE " GEN3(54(*LOD*),GETTYPE(BTYPE),
" LEVEL-" VLEVEL,DPLMT);
INDRCT: GEN2(35(*IND*),GETTYPE(BTYPE),IDPLMT);
INXD: ERROR(400)
END;
EXPR:
END;
### IF KIND = VARBL THEN VAR_REF := VAR_REF+1 ;
KIND := EXPR
END
END (*LOAD*) ;
PROCEDURE STORE(VAR FATTR: ATTR);
BEGIN
WITH FATTR DO
IF TYPTR <> NIL THEN
CASE ACCESS OF
# DRCT: GEN3(56(*STR*),GETTYPE(BTYPE),VLEVEL,DPLMT);
INDRCT: IF IDPLMT <> 0 THEN ERROR(400)
ELSE GEN1(26(*STO*),GETTYPE(BTYPE));
INXD: ERROR(400)
END
END (*STORE*) ;
(** LOADADDRESS GENFJP GENUJPFJP GENCUPENT MKNAME GENDEF CHKBNDS PUTLABEL CTRGEN CTREMIT **)
PROCEDURE LOADADDRESS;
BEGIN
WITH GATTR DO
IF TYPTR <> NIL THEN
BEGIN
CASE KIND OF
CST: IF STRING(TYPTR) THEN
# BEGIN
# CSTPTR := CVAL.VALP ; GEN1(37(*LCA*),0) ;
# END
ELSE ERROR(400);
VARBL: CASE ACCESS OF
# DRCT: GEN2(50(*LDA*),VLEVEL,DPLMT);
INDRCT: IF IDPLMT <> 0 THEN
GEN2(23(*INC*),ORD('A'),IDPLMT);
INXD: ERROR(400)
END;
EXPR: ERROR(400)
END;
KIND := VARBL; ACCESS := INDRCT; IDPLMT := 0
END
END (*LOADADDRESS*) ;
PROCEDURE GENFJP(FADDR: INTEGER);
BEGIN LOAD;
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> BOOLPTR THEN ERROR(144);
IF PRCODE THEN BEGIN PUTIC;
# WRITELN(PRR,MN[33]:4,' L',FADDR:FLDW(FADDR)) END;
IC := IC + 1
END (*GENFJP*) ;
PROCEDURE GENUJPFJP(FOP: OPRANGE; FP2: INTEGER);
BEGIN
IF PRCODE THEN
# BEGIN PUTIC; WRITELN(PRR, MN[FOP]:4, ' L',FP2:FLDW(FP2)) END;
IC := IC + 1
END (*GENUJPFJP*);
# PROCEDURE GENCUPENT(FOP: OPRANGE;FP0,FP1,FP2: INTEGER;PROCNAME: ALPHA);
# VAR TEMPNAME : ALPHA ;
#
# PROCEDURE MKNAME(VAR ALB: ALPHA; NLB: INTEGER ) ;
# VAR I, J: INTEGER ;
#
# BEGIN
# I := 1 ; J := 8 ;
# IF NOT XLINK THEN J := 5 ;
# REPEAT
# IF ALB[I] = '_' THEN ALB[I] := '$' ; I := I+1 ;
# UNTIL (I > J) OR (ALB[I] = ' ') ;
# IF NOT XLINK THEN
# FOR J := 8 DOWNTO I DO
# BEGIN
# ALB[J] := CHR( ORD('0')+ NLB MOD 10 ) ;
# NLB := NLB DIV 10 ;
# END ;
# END (*MKNAME*) ;
#
# BEGIN (*GENCUPENT*)
# IF PRCODE THEN
# BEGIN PUTIC ; TEMPNAME := PROCNAME ; (*TO PRESERVE FULL NAME*)
# IF FOP = 46 THEN (*CUP*)
# BEGIN MKNAME(TEMPNAME,FP2) ;
# WRITELN(PRR,MN[46],CHR(FP0):2,',',FP1:FLDW(FP1),',',TEMPNAME:8);
# END
# ELSE (*ENT*)
# BEGIN
#(*XSL10*) IF OLDIC = 0 THEN WRITELN(PRR,' BGN ', ORD(ASSEMBLE):1, ',',
#(*XSL10*) ORD(GET_STAT):1, ',', ORD(ASMVERB):1) ;
# IF FPROCP <> NIL THEN MKNAME(TEMPNAME,FP2) ;
# WRITELN(PRR, TEMPNAME:8, MN[32], CHR(FP0):2, ',',
# LEVEL:FLDW(LEVEL), ',L', FP1:FLDW(FP1), ' ',
#(*XSL10*) PROCNAME:IDLNGTH, ORD(SAVEREGS):4,
#(*XSL10*) ORD(SAVEFPRS):2, ORD(DEBUG):2) ;
# END ;
# END ;
# IC := IC + 1
# END (*GENCUPENT*);
#
# PROCEDURE GENDEF(L1, L2: ADDRRANGE ) ;
# BEGIN
# IF PRCODE THEN WRITELN(PRR,'L', L1:FLDW(L1), MN[63(*DEF*)], L2:10);
END (*GENDEF*) ;
#
#
# PROCEDURE CHKBNDS(FSP: STP);
# VAR LMIN,LMAX: INTEGER;
# BEGIN
# IF FSP <> NIL THEN
# IF FSP <> BOOLPTR THEN
# IF FSP <> INTPTR THEN
# IF FSP <> REALPTR THEN
# IF FSP↑.FORM <= POINTER THEN
# BEGIN
# GETBOUNDS(FSP,LMIN,LMAX);
# IF LMAX-LMIN <= 0 THEN
# IF ASSIGN THEN GEN3(45(*CHK*),ORD('A'),-1,0)
# ELSE (* ACCESS *) GEN3(45(*CHK*),ORD('A'),0,0)
# ELSE GEN3(45(*CHK*),ORD('I'),LMIN,LMAX) ;
# END
# END (*CHKBNDS*);
PROCEDURE PUTLABEL(LABNAME: INTEGER);
BEGIN IF PRCODE THEN WRITELN(PRR, 'L', LABNAME:FLDW(LABNAME),' LAB')
END (*PUTLABEL*);
"CTR"
"CTR"
"CTR" FUNCTION CTRGEN : CTRRANGE;
"CTR"
"CTR" BEGIN (* CREATE A UNIQUE STATEMENT COUNTER AND EMIT P-CODE TO INCREME
"CTR" IT *)
"CTR" (* R. L. SITES 3 AUG 77 *)
"CTR" CTRGEN := CTRCNT;
"CTR" IF CTROPTION THEN
"CTR" BEGIN
"CTR" GEN1(39(*CTI*), CTRCNT);
"CTR" CTRCNT := CTRCNT+1;
"CTR" END;
"CTR" END; (* CTRGEN *)
"CTR"
"CTR" PROCEDURE CTREMIT(CTRT:CTRTYPE; CTRNO:CTRRANGE; FLN, MLN, LLN:INTEGER) ;
"CTR"
"CTR"
"CTR" BEGIN (* WRITE AN ENTRY DESCRIBING A STATEMENT COUNTER. *)
"CTR" (* R. L. SITES 3 AUG 77 *)
"CTR" IF CTROPTION THEN
"CTR" BEGIN "" (* IF FIRSTCTR THEN
"CTR" BEGIN WRITELN(CTRTBL , COMPDATE); WRITELN(
"CTR" COMPTIME);
"CTR" FIRSTCTR := FALSE END;
"CTR" WRITELN("CTR"QRR,(((ORD(CTRT)*MAXCTR+CTRNO)*MAXLN+FLN)
"CTR" *MAXLN+MLN)*MAXLN+LLN:20); *) ""
"CTR" WRITELN(QRD, ORD(CTRT):4, CTRNO:6, FLN:7, MLN:7, LLN:7 );
"CTR" END
"CTR" (* PACKING MUST EITHER FIT IN 46 BITS OR MAXCTR,MAXLN MUST BE
"CTR" POWERS OF TWO. *)
"CTR" END; (* CTREMIT *)
"CTR"
(** STATEMENT EXPRESSION SELECTOR **)
PROCEDURE STATEMENT(FSYS: SETOFSYS);
LABEL 1;
VAR LCP: CTP; LLP: LBP; TTOP : DISPRANGE ;
"CTR" CTRNO : CTRRANGE;
PROCEDURE EXPRESSION(FSYS: SETOFSYS); FORWARD;
PROCEDURE SELECTOR(FSYS: SETOFSYS; FCP: CTP);
VAR LATTR: ATTR; LCP: CTP; LMIN,LMAX: INTEGER;
### INDEXING : BOOLEAN ;
BEGIN
### INDEXING := FALSE ;
WITH FCP↑, GATTR DO
BEGIN TYPTR := IDTYPE; KIND := VARBL;
###
### IF GET_STAT THEN
### BEGIN
### IF MODIFYING THEN WRITE(QRR,' #MOD')
### ELSE WRITE(QRR,' #REF') ;
### WRITE(QRR, CHR(GETTYPE("BTYPE" TYPTR)), ' ':2 );
### END (*GET_STAT*) ;
###
CASE KLASS OF
VARS:
IF VKIND = ACTUAL THEN
BEGIN ACCESS := DRCT; VLEVEL := VLEV;
DPLMT := VADDR
END
ELSE
BEGIN
### IF GET_STAT THEN WRITE(QRR,' #IND',VLEV:3,VADDR:8);
# GEN3(54(*LOD*),ORD('A'),VLEV,VADDR);
ACCESS := INDRCT; IDPLMT := 0
END;
FIELD:
WITH DISPLAY[DISX] DO
IF OCCUR = CREC THEN
BEGIN ACCESS := DRCT; VLEVEL := CLEV;
DPLMT := CDSPL + FLDADDR
END
ELSE
BEGIN
GEN3(54(*LOD*),ORD('A'), LEVEL,VDSPL) ;
### IF GET_STAT THEN WRITE(QRR,' #IND',LEVEL:3,VDSPL:8);
ACCESS := INDRCT; IDPLMT := FLDADDR
END;
FUNC:
IF PFDECKIND = STANDARD THEN ERROR(150)
ELSE
IF PFLEV = 0 THEN ERROR(150) (*EXTERNAL FCT*)
ELSE
IF PFKIND = FORMAL THEN ERROR(151)
ELSE
# IF (FPROCP <> FCP) THEN ERROR(177)
# ELSE
BEGIN ACCESS := DRCT; VLEVEL := PFLEV + 1;
DPLMT := FNCRSLT ; (*RELAT. ADDR. OF FCT. RESULT*)
### (* IF MODIFYING THEN
### WRITE(QRR,' DIR',VLEVEL:3, DPLMT:7) ; *)
END
END (*CASE*) ;
# GATTR.BTYPE := GATTR.TYPTR ;
END (*WITH*);
IF NOT (SY IN SELECTSYS + FSYS) THEN
BEGIN ERROR(59); SKIP(SELECTSYS + FSYS) END;
WHILE SY IN SELECTSYS DO
BEGIN
(*[*) IF SY = LBRACK THEN
BEGIN
###
### IF GET_STAT THEN
### WITH GATTR DO
### BEGIN
### IF ACCESS = DRCT THEN
### WRITE(QRR, ' #DIR',VLEVEL:3,DPLMT:8)
### ELSE IF (ACCESS = INDRCT) AND (IDPLMT <> 0) THEN
### WRITE(QRR,' #DPM ', IDPLMT:8) ;
### WRITE(QRR,' #INX ') ;
### IF MODIFYING THEN
### BEGIN INDEXING := TRUE ; MODIFYING := FALSE END ;
### END ;
###
REPEAT LATTR := GATTR;
WITH LATTR DO
IF TYPTR <> NIL THEN
IF TYPTR↑.FORM <> ARRAYS THEN
BEGIN ERROR(138); TYPTR := NIL END;
LOADADDRESS;
INSYMBOL; EXPRESSION(FSYS + [COMMA,RBRACK]);
LOAD;
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <> SCALAR THEN ERROR(113);
IF LATTR.TYPTR <> NIL THEN
WITH LATTR.TYPTR↑ DO
BEGIN
IF COMPTYPES(INXTYPE,GATTR.TYPTR) THEN
BEGIN
IF INXTYPE <> NIL THEN
BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX);
# IF DEBUG THEN
# GEN3(45(*CHK*),ORD('J'),LMIN,LMAX) ;
# IF LMIN > 0 THEN
# GEN2(22(*DEC*),GETTYPE(GATTR.BTYPE),LMIN)
# ELSE IF LMIN < 0 THEN
GEN2(23(*INC*),GETTYPE(GATTR.BTYPE),-LMIN)
# (*OR SIMPLY GEN1(31,LMIN)*)
END
END
ELSE ERROR(139);
WITH GATTR DO
BEGIN TYPTR := AELTYPE; KIND := VARBL;
ACCESS := INDRCT; IDPLMT := 0 ;
IF GATTR.TYPTR <> NIL THEN
# BEGIN LMIN := TYPTR↑.SIZE ;
# ALIGN(LMIN,TYPTR↑.ALN) ;
# GEN1(36(*IXA*),LMIN)
# END (*TYPTR <> NIL*) ;
END (*WITH GATTR DO*) ;
END
UNTIL SY <> COMMA;
IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12) ;
### IF INDEXING THEN
### BEGIN MODIFYING := TRUE ; INDEXING := FALSE END ;
END (*IF SY = LBRACK*)
ELSE
(*.*) IF SY = PERIOD THEN
BEGIN
WITH GATTR DO
BEGIN
IF TYPTR <> NIL THEN
IF TYPTR↑.FORM <> RECORDS THEN
BEGIN ERROR(140); TYPTR := NIL END;
INSYMBOL;
IF SY = IDENT THEN
BEGIN
IF TYPTR <> NIL THEN
BEGIN SEARCHSECTION(TYPTR↑.FSTFLD,LCP);
IF LCP = NIL THEN
BEGIN ERROR(152); TYPTR := NIL END
ELSE
WITH LCP↑ DO
BEGIN TYPTR := IDTYPE;
CASE ACCESS OF
DRCT: DPLMT := DPLMT + FLDADDR;
INDRCT: IDPLMT := IDPLMT + FLDADDR;
INXD: ERROR(400)
END
END
END;
INSYMBOL
END (*SY = IDENT*)
ELSE ERROR(2)
END (*WITH GATTR*)
END (*IF SY = PERIOD*)
ELSE
(*↑*) BEGIN
IF GATTR.TYPTR <> NIL THEN
WITH GATTR,TYPTR↑ DO
IF FORM = POINTER THEN
# BEGIN
### IF GET_STAT THEN
### IF ACCESS = DRCT THEN
### WRITE(QRR,' #PTR',VLEVEL:3,DPLMT:8)
### ELSE (*ACCESS = INDRCT *)
### WRITE(QRR,' #DPM ',"LEVEL:3,"IDPLMT:8) ;
# LOAD ;
# IF DEBUG THEN CHKBNDS(GATTR.TYPTR) ;
# TYPTR := ELTYPE ;
WITH GATTR DO
BEGIN KIND := VARBL; ACCESS := INDRCT;
IDPLMT := 0
END
END
ELSE
IF FORM = FILES THEN TYPTR := FILTYPE
ELSE ERROR(141);
INSYMBOL
END;
IF NOT (SY IN FSYS + SELECTSYS) THEN
BEGIN ERROR(6); SKIP(FSYS + SELECTSYS) END ;
# GATTR.BTYPE := GATTR.TYPTR ;
END (*WHILE*) ;
###
### IF GET_STAT THEN
### WITH GATTR DO
### BEGIN
### IF ACCESS = DRCT THEN
### WRITE(QRR,' #DIR', VLEVEL:3,DPLMT:8)
### ELSE IF (ACCESS = INDRCT) AND (IDPLMT <> 0) THEN
### WRITE(QRR, ' #DPM ',IDPLMT:8) ;
### IF MODIFYING THEN WRITE(QRR, ' #MND ')
### ELSE WRITE(QRR,' #RND ') ;
### END ;
###
END (*SELECTOR*) ;
(** CALL VARIABLE RWSETUP GETPUTRESETREWRITE READ1 **)
PROCEDURE CALL(FSYS: SETOFSYS; FCP: CTP);
VAR LKEY: 1..NSPROC;
PROCEDURE VARIABLE(FSYS: SETOFSYS);
VAR LCP: CTP;
BEGIN
IF SY = IDENT THEN
BEGIN SEARCHID([VARS,FIELD],LCP); INSYMBOL END
ELSE BEGIN ERROR(2); LCP := UVARPTR END;
SELECTOR(FSYS,LCP)
END (*VARIABLE*) ;
# PROCEDURE RWSETUP(DFILE: ALPHA) ;
# (* TO SET UP FILE ADDRESS PARAMETER FOR READ/WRITE *)
#
# VAR LCP : CTP ; SAVED : BOOLEAN ; TEMPID : ALPHA ; TEMPSY : SYMBOL ;
#
# BEGIN SAVED := TRUE ;
#
# IF SY = IDENT THEN
# BEGIN SEARCHID([VARS,FIELD,FUNC,KONST],LCP) ;
# IF LCP↑.IDTYPE <> NIL THEN
# WITH LCP↑.IDTYPE↑ DO
# IF FORM = FILES THEN
# IF FILTYPE = CHARPTR THEN SAVED := FALSE
# ELSE ERROR(398) ;
# END (* SY = IDENT *) ;
#
# IF SAVED THEN (* USE IMPLIED FILE NAME *)
# BEGIN TEMPSY := SY ; TEMPID := ID ; SY := COMMA ; ID := DFILE ;
# SEARCHID([VARS],LCP) ;
# END (* IF SAVED *)
# ELSE INSYMBOL ;
#
# SELECTOR(FSYS+[COMMA,RPARENT],LCP) ; LOADADDRESS ; (* GET FILE ADR *)
# GEN1(30(*CSP*),31(*SIO*)) ;
# IF SAVED THEN BEGIN ID := TEMPID ; SY := TEMPSY END ;
# END (*RWSETUP*) ;
#
PROCEDURE GETPUTRESETREWRITE;
BEGIN "VARIABLE(FSYS + [RPARENT]); LOADADDRESS;"
## # IF ODD(LKEY) (*GET, RESET*) THEN RWSETUP(NA[39] (*INPUT*))
## # ELSE (*PUT, REWRITE*) RWSETUP(NA[40] (*OUTPUT*) ) ;
# IF EBCDFLG THEN
# IF LKEY > 2 THEN (*RESET , REWRITE*)
# BEGIN GEN2(23(*INC*),ORD('A'),1000) ; EBCDFLG := FALSE END ;
" IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <> FILES THEN ERROR(116);
# GEN1(30(*CSP*),31(*SIO*)) ; "
# GEN1(30(*CSP*),LKEY(*GET,PUT,RES,REW*)) ;
# GEN1(30(*CSP*),30(*EIO*)) ;
END (*GETPUTRESETREWRITE*) ;
PROCEDURE READ1;
" VAR LCP:CTP; LLEV:LEVRANGE; LADDR:ADDRRANGE; "
# BEGIN "LLEV := 1 ; LADDR := FIRSTFILBUF ;"(*ASSUME 'INPUT'*)
## # " IF (SY IN [IDENT,SEMICOLON]) THEN" RWSETUP(NA[39] (*'INPUT '*));
" ELSE BEGIN ERROR(2) ; INSYMBOL END ; "
IF SY = COMMA THEN INSYMBOL ;
## # IF LKEY = 5 (*READ*) THEN IF SY <> IDENT THEN ERROR(2) ;
IF SY = IDENT THEN
### REPEAT MODIFYING := TRUE ;
### VARIABLE(FSYS + [COMMA,RPARENT]) ; MODIFYING := FALSE ;
LOADADDRESS ;
IF GATTR.TYPTR <> NIL THEN
# IF STRING(GATTR.TYPTR) THEN
# BEGIN
# GEN2(51(*LDC*),1,GATTR.TYPTR↑.SIZE DIV CHARSIZE) ;
# GEN1(30(*CSP*),27(*RDS*))
# END
# ELSE
# BEGIN
IF COMPTYPES(INTPTR,GATTR.TYPTR) THEN
GEN1(30(*CSP*),24(*RDI*))
ELSE
IF COMPTYPES(REALPTR,GATTR.TYPTR) THEN
GEN1(30(*CSP*),14(*RDR*))
ELSE
IF COMPTYPES(CHARPTR,GATTR.TYPTR) THEN
GEN1(30(*CSP*),5(*RDC*))
# ELSE
# IF COMPTYPES(BOOLPTR,GATTR.TYPTR) THEN
# GEN1(30(*CSP*),12(*RDB*))
# ELSE ERROR(116) ;
# END ;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST ;
IF LKEY = 11 THEN
BEGIN
GEN1(30(*CSP*),23(*RLN*))
END ;
GEN1(30(*CSP*),30(*EIO*)) ;
END (*READ*) ;
(** WRITE1 PACK1 UNPACK1 **)
PROCEDURE WRITE1;
VAR LSP: STP; DEFAULT, DEFAULT1 : BOOLEAN; LLKEY: 1..NSPROC;
LEN:ADDRRANGE;
# BEGIN LLKEY := LKEY; TEST := FALSE ;
# RWSETUP(NA[40] (*'OUTPUT '*) ) ;
# " IF SY = RPARENT THEN
# BEGIN TEST := TRUE ; IF LLKEY = 6 THEN ERROR(116) ; END ; "
# IF SY = COMMA THEN
# BEGIN INSYMBOL; IF NOT (SY IN CONSTBEGSYS) THEN ERROR(6) END ;
# IF SY IN CONSTBEGSYS THEN
# REPEAT EXPRESSION(FSYS+[COMMA,COLON,RPARENT]) ;
LSP := GATTR.TYPTR;
IF LSP <> NIL THEN
IF LSP↑.FORM <= SUBRANGE THEN LOAD ELSE LOADADDRESS;
DEFAULT := TRUE ; DEFAULT1 := TRUE ;
IF SY = COLON THEN
BEGIN INSYMBOL; EXPRESSION(FSYS + [COMMA,COLON,RPARENT]);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> INTPTR THEN ERROR(116);
LOAD; DEFAULT := FALSE ;
IF SY = COLON THEN
BEGIN INSYMBOL; EXPRESSION(FSYS + [COMMA,RPARENT]);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> INTPTR THEN ERROR(116);
IF LSP <> REALPTR THEN ERROR(124);
## # LOAD; DEFAULT1 := FALSE ; " ERROR(398); "
END ;
END ;
IF LSP = INTPTR THEN
BEGIN IF DEFAULT THEN GEN2(51(*LDC*),1,12);
GEN1(30(*CSP*),6(*WRI*))
END
ELSE
IF LSP = REALPTR THEN
BEGIN IF DEFAULT THEN GEN2(51(*LDC*),1,14);
IF DEFAULT1 THEN GEN2(51(*LDC*),1,0);
GEN1(30(*CSP*),8(*WRR*))
END
ELSE
IF LSP = CHARPTR THEN
BEGIN IF DEFAULT THEN GEN2(51(*LDC*),1,1);
GEN1(30(*CSP*),9(*WRC*))
END
ELSE
# IF LSP = BOOLPTR THEN
# BEGIN IF DEFAULT THEN GEN2(51(*LDC*),1,5);
# GEN1(30(*CSP*),13(*WRB*))
# END
# ELSE
IF LSP <> NIL THEN
BEGIN
IF LSP↑.FORM = SCALAR THEN ERROR(398)
ELSE
IF STRING(LSP) THEN
BEGIN LEN := LSP↑.SIZE DIV CHARSIZE;
IF DEFAULT THEN
GEN2(51(*LDC*),1,LEN);
GEN2(51(*LDC*),1,LEN);
GEN1(30(*CSP*),10(*WRS*))
END
ELSE ERROR(116)
END;
TEST := SY <> COMMA;
# IF NOT TEST THEN INSYMBOL ;
# UNTIL TEST;
#
IF LLKEY = 12 THEN (*WRITELN*)
BEGIN
GEN1(30(*CSP*),22(*WLN*))
END ;
# GEN1(30(*CSP*),30(*EIO*)) ;
END (*WRITE*) ;
PROCEDURE PACK1;
VAR LSP,LSP1: STP;
BEGIN ERROR(398); VARIABLE(FSYS + [COMMA,RPARENT]);
LSP := NIL; LSP1 := NIL;
IF GATTR.TYPTR <> NIL THEN
WITH GATTR.TYPTR↑ DO
IF FORM = ARRAYS THEN
BEGIN LSP := INXTYPE; LSP1 := AELTYPE END
ELSE ERROR(116);
IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
EXPRESSION(FSYS + [COMMA,RPARENT]);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <> SCALAR THEN ERROR(116)
ELSE
IF NOT COMPTYPES(LSP,GATTR.TYPTR) THEN ERROR(116);
IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
VARIABLE(FSYS + [RPARENT]);
IF GATTR.TYPTR <> NIL THEN
WITH GATTR.TYPTR↑ DO
IF FORM = ARRAYS THEN
BEGIN
IF NOT COMPTYPES(AELTYPE,LSP1)
OR NOT COMPTYPES(INXTYPE,LSP) THEN
ERROR(116)
END
ELSE ERROR(116)
END (*PACK*) ;
PROCEDURE UNPACK1;
VAR LSP,LSP1: STP;
BEGIN ERROR(398); VARIABLE(FSYS + [COMMA,RPARENT]);
LSP := NIL; LSP1 := NIL;
IF GATTR.TYPTR <> NIL THEN
WITH GATTR.TYPTR↑ DO
IF FORM = ARRAYS THEN
BEGIN LSP := INXTYPE; LSP1 := AELTYPE END
ELSE ERROR(116);
IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
VARIABLE(FSYS + [COMMA,RPARENT]);
IF GATTR.TYPTR <> NIL THEN
WITH GATTR.TYPTR↑ DO
IF FORM = ARRAYS THEN
BEGIN
IF NOT COMPTYPES(AELTYPE,LSP1)
OR NOT COMPTYPES(INXTYPE,LSP) THEN
ERROR(116)
END
ELSE ERROR(116);
IF SY = COMMA THEN INSYMBOL ELSE ERROR(20);
EXPRESSION(FSYS + [RPARENT]);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <> SCALAR THEN ERROR(116)
ELSE
IF NOT COMPTYPES(LSP,GATTR.TYPTR) THEN ERROR(116);
END (*UNPACK*) ;
(** NEW1 MARK1 RELEASE1 TRAPEXIT **)
PROCEDURE NEW1;
LABEL 1;
VAR LSP,LSP1: STP; VARTS,LMIN,LMAX: INTEGER;
LSIZE,LSZ: ADDRRANGE; LVAL: VALU;
BEGIN VARIABLE(FSYS + [COMMA,RPARENT]); LOADADDRESS;
LSP := NIL; VARTS := 0; LSIZE := 0;
IF GATTR.TYPTR <> NIL THEN
WITH GATTR.TYPTR↑ DO
IF FORM = POINTER THEN
BEGIN
IF ELTYPE <> NIL THEN
BEGIN LSIZE := ELTYPE↑.SIZE;
IF ELTYPE↑.FORM = RECORDS THEN LSP := ELTYPE↑.RECVAR
END
END
ELSE ERROR(116);
WHILE SY = COMMA DO
BEGIN INSYMBOL;CONSTANT(FSYS + [COMMA,RPARENT],LSP1,LVAL);
VARTS := VARTS + 1;
(*CHECK TO INSERT HERE: IS CONSTANT IN TAGFIELDTYPE RANGE*)
IF LSP = NIL THEN ERROR(158)
ELSE
IF LSP↑.FORM <> TAGFLD THEN ERROR(162)
ELSE
IF LSP↑.TAGFIELDP <> NIL THEN
IF STRING(LSP1) OR (LSP1 = REALPTR) THEN ERROR(159)
ELSE
IF COMPTYPES(LSP↑.TAGFIELDP↑.IDTYPE,LSP1) THEN
BEGIN
LSP1 := LSP↑.FSTVAR;
WHILE LSP1 <> NIL DO
WITH LSP1↑ DO
IF VARVAL.IVAL = LVAL.IVAL THEN
BEGIN LSIZE := SIZE; LSP := SUBVAR;
GOTO 1
END
ELSE LSP1 := NXTVAR;
LSIZE := LSP↑.SIZE; LSP := NIL;
END
ELSE ERROR(116);
1: END (*WHILE*) ;
# ALIGN(LSIZE,MXDATASZE) ;
# GEN1(58(*NEW*),LSIZE);
END (*NEW*) ;
PROCEDURE MARK1;
BEGIN VARIABLE(FSYS+[RPARENT]);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM = POINTER THEN
BEGIN LOADADDRESS; GEN0(59(*SAV*)) END
ELSE ERROR(125)
END(*MARK*);
PROCEDURE RELEASE1;
BEGIN VARIABLE(FSYS+[RPARENT]);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM = POINTER THEN
BEGIN LOAD; GEN0(60(*RST*)) END
ELSE ERROR(125)
END (*RELEASE*);
# PROCEDURE TRAPEXIT ;
#
# (*THIS PROCEDURE IS TO FACILITATE COMMUNICATION WITH THE OUTSIDE WORLD
# (* AND PROVIDE BREAK POINTS IN THE PASCAL PROGRAM.
# (* 'TRAP(I, R)' RETURNS THE INTEGER CONSTANT I AS WELL AS A POINTER
# (* TO THE SECOND PARAMETER 'R' (I.E. ADDRESS OF R) TO THE OPERATING
# (* SYSTEM. THE FIRST PARAMETER IS INTENDED TO BE USED AS A
# (* 'FUNCTION NUMBER' AND THE SECOND ONE AS THE 'VAR' TYPE ARGUMENT
# (* WHICH MAY BE INSPECTED AND MODIFIED, TO THAT FUNCTION *)
#
# BEGIN " EXPRESSION(FSYS+[RPARENT,COMMA]) ; "
# IF GATTR.TYPTR <> INTPTR THEN ERROR(116) ;
# IF LKEY = 14 THEN (*TRAP*)
# BEGIN
# IF SY <> COMMA THEN ERROR(6)
# ELSE
# BEGIN INSYMBOL ;
# EXPRESSION(FSYS+[RPARENT]) ;
# WITH GATTR DO
# IF TYPTR <> NIL THEN
# BEGIN
# IF KIND <> VARBL THEN
# IF TYPTR↑.FORM <= POWER THEN
# BEGIN LOAD ;
# KIND := VARBL ; ACCESS := DRCT ; VLEVEL := LEVEL ;
# ALIGN(LC,MXDATASZE) ; DPLMT := LC ; BTYPE := TYPTR ;
# STORE(GATTR) ;
# END ;
# LOADADDRESS ;
# END ;
# END (*WITH*) ;
# END ;
# GEN1(30(*CSP*),LKEY+14 (*TRP*) (*XIT*)) ;
# END (* TRAPEXIT *) ;
(** ABS1 SQR1 TRUNC1 ODD1 ORD1 CHR1 PREDSUCCTIM EOFEOLN MATH **)
PROCEDURE ABS1;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR = INTPTR THEN GEN0(0(*ABI*))
ELSE
IF GATTR.TYPTR = REALPTR THEN GEN0(1(*ABR*))
ELSE BEGIN ERROR(125); GATTR.TYPTR := INTPTR END
END (*ABS*) ;
PROCEDURE SQR1;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR = INTPTR THEN GEN0(24(*SQI*))
ELSE
IF GATTR.TYPTR = REALPTR THEN GEN0(25(*SQR*))
ELSE BEGIN ERROR(125); GATTR.TYPTR := INTPTR END
END (*SQR*) ;
PROCEDURE TRUNC1;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> REALPTR THEN ERROR(125);
GEN0(27(*TRC*));
GATTR.TYPTR := INTPTR
END (*TRUNC*) ;
PROCEDURE ODD1;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> INTPTR THEN ERROR(125);
GEN0(20(*ODD*));
GATTR.TYPTR := BOOLPTR
END (*ODD*) ;
PROCEDURE ORD1;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM >= POWER THEN ERROR(125);
# GEN0(61(*ORD*)) ;
GATTR.TYPTR := INTPTR
END (*ORD1*) ;
PROCEDURE CHR1;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> INTPTR THEN ERROR(125);
# GEN0(62(*CHR*)) ;
GATTR.TYPTR := CHARPTR
END (*CHR*) ;
PROCEDURE PREDSUCCTIM;
# BEGIN (*ERROR(398);*) (*TRANSLATES INTO 'DEC' AND 'INC'*)
# IF GATTR.TYPTR <> NIL THEN
# IF LKEY = 24 THEN
# BEGIN IF GATTR.TYPTR <> INTPTR THEN ERROR(116) ;
# GEN1(30(*CSP*),21(*CLK*)) ;
# END
# ELSE
# IF (GATTR.TYPTR = REALPTR) OR (GATTR.TYPTR↑.FORM <> SCALAR) THEN
# ERROR(125)
# ELSE GEN2(LKEY(*DEC,INC*),GETTYPE(GATTR.BTYPE),1) ;
(* LKEY HAPPENS TO BE THE OPCODE AS WELL *)
# END (*PREDSUCCTIM*) ;
PROCEDURE EOFEOLN;
BEGIN
## # RWSETUP(NA[39] (*'INPUT '*) ) ;
# " GEN1(30(*CSP*),31(*SIO*)) ;
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <> FILES THEN ERROR(125); "
# " IF LKEY = 10 THEN GEN1(30(*CSP*),25(*EOF*))
ELSE GEN1(30(*CSP*),26(*ELN*)); "
(* LKEY HAPPENS TO BE THE CSP NUMBER AS WELL ! *)
## # GEN1(30(*CSP*), LKEY(*EOF*)(*ELN*)) ;
# GEN1(30(*CSP*),30(*EIO*)) ;
GATTR.TYPTR := BOOLPTR
END (*EOF*) ;
PROCEDURE MATH;
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR = INTPTR THEN
BEGIN GEN0(10(*FLT*)) ;
GATTR.TYPTR := REALPTR ;
END ;
IF GATTR.TYPTR <> REALPTR THEN ERROR(116)
ELSE GEN1(30(*CSP*), LKEY-12(*SIN..ATAN*)) ;
END (*MATH*) ;
(** CALLNONSTANDARD **)
PROCEDURE CALLNONSTANDARD;
VAR NXT,LCP: CTP; LSP: STP; LKIND: IDKIND; LB: BOOLEAN;
LOCPAR, LLC: ADDRRANGE;
BEGIN LOCPAR := 0;
WITH FCP↑ DO
BEGIN NXT := NEXT; LKIND := PFKIND;
# " IF NOT EXTRN THEN
# BEGIN "
"S0" " GEN1(41(*MST*),PFLEV) ; "
"S1" GEN3(41(*MST*), PFLEV+1, FPRMSZE, RPRMSZE) ;
###
### T_CLIST := CALL_HEAD ;
### WHILE NAME > T_CLIST↑.NAME DO T_CLIST := T_CLIST↑.NXT; (*X10S1*)
### (*EJG*)(* WHILE NAME < T_CLIST↑.NAME DO T_CLIST := T_CLIST↑.NXT;*)(*X10S1*)
(* EJG 11/25/78 Above comparison crock is because all spaces are larger than
identifier names in 370 PASCAL and PDP-10 PASCAL (because ID's are
negative on PDP-10!), but smaller on S-1 PASCAL. Sigh. This should
be fixed better someday...*)
### IF T_CLIST↑.NAME <> NAME THEN
### BEGIN NEW(T2_CLIST) ; T2_CLIST↑ := T_CLIST↑ ;
### T_CLIST↑.NAME := NAME ; T_CLIST↑.NXT := T2_CLIST ;
### T_CLIST↑.CNT := 1 ; T_CLIST↑.LVL := PFLEV ;
### IF PFLEV = LEVEL THEN LOCAL_CALL := TRUE ;
### END
### ELSE T_CLIST↑.CNT := T_CLIST↑.CNT+1 ;
###
# " END (* IF NOT EXTRN *) ; "
END;
IF SY = LPARENT THEN
BEGIN LLC := LC;
REPEAT LB := FALSE; (*DECIDE WHETHER PROC/FUNC MUST BE PASSED*)
IF LKIND = ACTUAL THEN
BEGIN
IF NXT = NIL THEN ERROR(126)
ELSE LB := NXT↑.KLASS IN [PROC,FUNC]
END ELSE ERROR(398);
(*FOR FORMAL PROC/FUNC LB IS FALSE AND EXPRESSION
WILL BE CALLED, WHICH WILL ALLWAYS INTERPRET A PROC/FUNC ID
AT ITS BEGINNING AS A CALL RATHER THAN A PARAMETER PASSING.
IN THIS IMPLEMENTATION, PARAMETER PROCEDURES/FUNCTIONS
ARE THEREFORE NOT ALLOWED TO HAVE PROCEDURE/FUNCTION
PARAMETERS*)
INSYMBOL;
IF LB THEN (*PASS FUNCTION OR PROCEDURE*)
BEGIN ERROR(398);
IF SY <> IDENT THEN
BEGIN ERROR(2); SKIP(FSYS + [COMMA,RPARENT]) END
ELSE
BEGIN
IF NXT↑.KLASS = PROC THEN SEARCHID([PROC],LCP)
ELSE
BEGIN SEARCHID([FUNC],LCP);
IF NOT COMPTYPES(LCP↑.IDTYPE,NXT↑.IDTYPE) THEN
ERROR(128)
END;
INSYMBOL;
IF NOT (SY IN FSYS + [COMMA,RPARENT]) THEN
BEGIN ERROR(6); SKIP(FSYS + [COMMA,RPARENT]) END
END
END (*IF LB*)
ELSE
BEGIN
### IF NXT <> NIL THEN
### IF NXT↑.VKIND = FORMAL THEN MODIFYING := TRUE ;
EXPRESSION(FSYS + [COMMA,RPARENT]);
### MODIFYING := FALSE ;
IF GATTR.TYPTR <> NIL THEN
IF LKIND = ACTUAL THEN
BEGIN
IF NXT <> NIL THEN
BEGIN LSP := NXT↑.IDTYPE;
IF LSP <> NIL THEN
BEGIN
IF (NXT↑.VKIND = ACTUAL) THEN
# IF LSP↑.FORM <= POWER THEN
# BEGIN LOAD;
# IF DEBUG THEN
# BEGIN ASSIGN := TRUE ;
# CHKBNDS(LSP) ; ASSIGN := FALSE ;
# END ;
IF COMPTYPES(REALPTR,LSP)
AND (GATTR.TYPTR = INTPTR) THEN
BEGIN GEN0(10(*FLT*));
GATTR.TYPTR := REALPTR
END;
LOCPAR := LOCPAR+ 1 (*LSP↑.SIZE*) ;
# IF PACKDATA THEN
# BEGIN
# IF LSP↑.SIZE = 4 THEN GEN0(61(*ORD*));
# IF LSP↑.SIZE = 1 THEN GEN0(62(*CHR*));
END (*PACKDATA*) ;
"S1" IF NOT FCP↑.EXTRN THEN
"S1" GEN1(64(*PRM*), GETTYPE(LSP));
END
ELSE
BEGIN
LOADADDRESS;
LOCPAR := LOCPAR+ 1 (*PTRSIZE*);
"S1" IF NOT FCP↑.EXTRN THEN
"S1" GEN1(64(*PRM*), ORD('A')) ;
END
ELSE (* VKIND = FORMAL I.E. VAR PARM *)
IF GATTR.KIND = VARBL THEN
BEGIN LOADADDRESS;
LOCPAR := LOCPAR + 1 (*PTRSIZE*);
"S1" IF NOT FCP↑.EXTRN THEN
"S1" GEN1(64(*PRM*), ORD('A')) ;
IF GATTR.BTYPE↑.SIZE <> LSP↑.SIZE THEN
ERROR(142) ;
END
ELSE ERROR(154);
IF NOT COMPTYPES(LSP,GATTR.TYPTR) THEN
ERROR(142)
END
END
END
ELSE (*LKIND = FORMAL*)
BEGIN (*PASS FORMAL PROC/FUNC PARAM*)
END
END;
IF (LKIND = ACTUAL) AND (NXT <> NIL) THEN NXT := NXT↑.NEXT
UNTIL SY <> COMMA;
LC := LLC;
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END (*IF LPARENT*);
# LOCPAR := LOCPAR*2 ;
IF LKIND = ACTUAL THEN
BEGIN IF NXT <> NIL THEN ERROR(126);
WITH FCP↑ DO
" IF EXTRN THEN GEN1(30(*CSP*),PFNAME)
# ELSE "
# BEGIN
# IF SAVEFP THEN LOCPAR := LOCPAR+1 ; (*ENCODE SAVE FPR FLG*)
GENCUPENT(46(*CUP*),PROCTYPE(FCP),LOCPAR,PFNAME,NAME);
END ;
END;
# GATTR.TYPTR := FCP↑.IDTYPE ; GATTR.BTYPE := GATTR.TYPTR ;
END (*CALLNONSTANDARD*) ;
BEGIN (*CALL*)
IF FCP↑.PFDECKIND = STANDARD THEN
BEGIN "IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9);"
LKEY := FCP↑.KEY;
## # IF SY = LPARENT THEN
## # BEGIN INSYMBOL ;
## # IF SY = RPARENT THEN
## # IF NOT (LKEY IN [1,2,3,4,11,12,25,26]) THEN ERROR(7) ;
(*GET,PUT,RESET,REWRITE,RDLN,WRITELN,EOF,ELN*)
## # END
## # ELSE
## # BEGIN IF NOT (LKEY IN [1,2,3,4,11,12,25,26]) THEN ERROR(6) ;
(*GET,PUT,RESET,REWRITE,RDLN,WRITELN,EOF,ELN*)
## # IF SY =RPARENT THEN ERROR(6) ;
## # END ;
" IF FCP↑.KLASS = PROC THEN "
## #
## # IF LKEY IN [14..24, 27..32 (*TRAP,EXIT,ABS..MATH*)] THEN
## # BEGIN
IF LKEY = 14 (*TRAP*) THEN EXPRESSION(FSYS+[COMMA])
ELSE EXPRESSION(FSYS+[RPARENT]) ;
LOAD ;
END ;
## #
CASE LKEY OF
1,2,
3,4: GETPUTRESETREWRITE;
5,11: READ1;
6,12: WRITE1;
7: PACK1;
8: UNPACK1;
9: NEW1;
10: RELEASE1;
13: MARK1;
14,15: TRAPEXIT ;
" END
ELSE
BEGIN EXPRESSION(FSYS + [RPARENT]);
IF LKEY <= 9 THEN LOAD ELSE LOADADDRESS;
CASE LKEY OF "
16: ABS1;
17: SQR1;
18: TRUNC1;
19: ODD1;
20: ORD1;
21: CHR1;
22,23,24 :PREDSUCCTIM;
25,26 :EOFEOLN ;
## # 27,28,29,
## # 30,31,32 :MATH ;
END (*CASE LKEY OF*) ;
# IF LKEY IN [16..24, 27..32] THEN GATTR.BTYPE := GATTR.TYPTR ;
## # IF SY = RPARENT THEN INSYMBOL
## # ELSE IF NOT (LKEY IN [1,2,3,4,11,12,25,26]) THEN ERROR(4) ;
END (*STANDARD PROCEDURES AND FUNCTIONS*)
ELSE CALLNONSTANDARD
END (*CALL*) ;
(** EXPRESSION SIMPLEEXPRESSION TERM FACTOR **)
PROCEDURE EXPRESSION;
VAR LATTR: ATTR; LOP: OPERATOR; TYPIND: CHAR; LSIZE: ADDRRANGE;
PROCEDURE SIMPLEEXPRESSION(FSYS: SETOFSYS);
VAR LATTR: ATTR; LOP: OPERATOR; SIGNED: BOOLEAN;
PROCEDURE TERM(FSYS: SETOFSYS);
VAR LATTR: ATTR; LOP: OPERATOR;
PROCEDURE FACTOR(FSYS: SETOFSYS);
VAR LCP: CTP; LVP: CSP; VARPART: BOOLEAN;
(*SETCH*) CSTPART: SETREP; LSP: STP; I: SET_EL_TYP;
BEGIN
IF NOT (SY IN FACBEGSYS) THEN
BEGIN ERROR(58); SKIP(FSYS + FACBEGSYS);
GATTR.TYPTR := NIL
END;
WHILE SY IN FACBEGSYS DO
BEGIN
CASE SY OF
(*ID*) IDENT:
BEGIN SEARCHID([KONST,VARS,FIELD,FUNC],LCP);
INSYMBOL;
IF LCP↑.KLASS = FUNC THEN
# BEGIN CALL(FSYS,LCP);
# WITH GATTR DO
# BEGIN KIND := EXPR;
# IF TYPTR <> NIL THEN
# IF TYPTR↑.FORM=SUBRANGE THEN
# TYPTR := TYPTR↑.RANGETYPE
# END
# END
ELSE
IF LCP↑.KLASS = KONST THEN
WITH GATTR, LCP↑ DO
BEGIN TYPTR := IDTYPE; KIND := CST;
# CVAL := VALUES; GATTR.BTYPE := GATTR.TYPTR
END
ELSE
BEGIN SELECTOR(FSYS,LCP);
IF GATTR.TYPTR<>NIL THEN(*ELIM.SUBR.TYPES TO*)
WITH GATTR,TYPTR↑ DO(*SIMPLIFY LATER TESTS*)
IF FORM = SUBRANGE THEN
TYPTR := RANGETYPE
END
END;
(*CST*) INTCONST:
BEGIN
WITH GATTR DO
BEGIN TYPTR := INTPTR; KIND := CST;
# CVAL := VAL; BTYPE := TYPTR
END;
INSYMBOL
END;
REALCONST:
BEGIN
WITH GATTR DO
BEGIN TYPTR := REALPTR; KIND := CST;
CVAL := VAL
END;
INSYMBOL
END;
STRINGCONST:
BEGIN
WITH GATTR DO
BEGIN
IF LNGTH = 1 THEN TYPTR := CHARPTR
ELSE
BEGIN NEW(LSP,ARRAYS);
WITH LSP↑ DO
BEGIN AELTYPE := CHARPTR; FORM:=ARRAYS;
INXTYPE := NIL; SIZE := LNGTH*CHARSIZE
END;
TYPTR := LSP
END;
KIND := CST; CVAL := VAL
END;
INSYMBOL
END;
(*(*) LPARENT:
BEGIN INSYMBOL; EXPRESSION(FSYS + [RPARENT]);
IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4)
END;
(*NOT*) NOTSY:
BEGIN INSYMBOL; FACTOR(FSYS);
LOAD; GEN0(19(*NOT*));
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR <> BOOLPTR THEN
BEGIN ERROR(135); GATTR.TYPTR := NIL END;
END;
(*[*) LBRACK:
BEGIN INSYMBOL;
(*SETCH*) CSTPART := NULL_SET;
VARPART := FALSE;
NEW(LSP,POWER);
WITH LSP↑ DO
BEGIN ELSET:=NIL;SIZE:=SETSIZE;FORM:=POWER END;
IF SY = RBRACK THEN
BEGIN
WITH GATTR DO
BEGIN TYPTR := LSP; KIND := CST END;
INSYMBOL
END
ELSE
BEGIN
# REPEAT EXPRESSION(FSYS + [COMMA,DOTDOT,RBRACK]);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <> SCALAR THEN
BEGIN ERROR(136); GATTR.TYPTR := NIL END
ELSE
IF COMPTYPES(LSP↑.ELSET,GATTR.TYPTR) THEN
BEGIN
IF GATTR.KIND = CST THEN
# BEGIN
# IF (GATTR.CVAL.IVAL < 0) THEN
# ERROR(304)
# ELSE
#(*SETCH*) BUILD_SET(GATTR.CVAL.IVAL,CSTPART);
# IF SY = DOTDOT THEN (*RANGE GIVEN*)
# BEGIN INSYMBOL ; LATTR := GATTR ;
# EXPRESSION(FSYS+[COMMA,RBRACK]) ;
# IF GATTR.TYPTR <> LATTR.TYPTR THEN
# ERROR(137)
# ELSE
# FOR I := LATTR.CVAL.IVAL TO
# GATTR.CVAL.IVAL DO
#(*SETCH*) BUILD_SET(I,CSTPART);
# END (* IF SY = COLON *) ;
# IF GATTR.CVAL.IVAL > MAXSETEL THEN
# ERROR(304) ;
# END (* GATTR.KIND = CST *)
# ELSE
# BEGIN LOAD;
# IF NOT COMPTYPES(GATTR.TYPTR,INTPTR)
# THEN GEN0(61(*ORD*));
# IF DEBUG THEN
# GEN3(45(*CHK*),ORD('S'),0,MAXSETEL);
# GEN0(29(*SGS*));
IF VARPART THEN GEN0(28(*UNI*))
ELSE VARPART := TRUE
END;
LSP↑.ELSET := GATTR.TYPTR;
GATTR.TYPTR := LSP
END
ELSE ERROR(137);
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12)
END;
IF VARPART THEN
BEGIN
(*SETCH*) IF CSTPART <> NULL_SET THEN
BEGIN NEW(LVP,PSET); LVP↑.PVAL := CSTPART;
"LVP↑.CCLASS := PSET;"
# CSTPTR := LVP;
# GEN2(51(*LDC*),5,0);
GEN0(28(*UNI*)); GATTR.KIND := EXPR
END
END
ELSE
BEGIN NEW(LVP,PSET); LVP↑.PVAL := CSTPART;
"LVP↑.CCLASS := PSET;"
GATTR.CVAL.VALP := LVP
END
END
END (*CASE*) ;
IF NOT (SY IN FSYS) THEN
BEGIN ERROR(6); SKIP(FSYS + FACBEGSYS) END
END (*WHILE*)
END (*FACTOR*) ;
BEGIN (*TERM*)
FACTOR(FSYS + [MULOP]);
WHILE SY = MULOP DO
BEGIN LOAD; LATTR := GATTR; LOP := OP;
INSYMBOL; FACTOR(FSYS + [MULOP]); LOAD;
IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN
CASE LOP OF
(***) MUL: IF (LATTR.TYPTR=INTPTR)AND(GATTR.TYPTR=INTPTR)
THEN GEN0(15(*MPI*))
ELSE
BEGIN
# IF GATTR.TYPTR = INTPTR THEN
# BEGIN GEN0(10(*FLT*));
# GATTR.TYPTR := REALPTR
# END
# ELSE
# IF LATTR.TYPTR = INTPTR THEN
# BEGIN GEN0(9(*FLO*));
# LATTR.TYPTR := REALPTR
END;
IF (LATTR.TYPTR = REALPTR)
AND(GATTR.TYPTR=REALPTR)THEN GEN0(16(*MPR*))
ELSE
IF(LATTR.TYPTR↑.FORM=POWER)
AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR)THEN
GEN0(12(*INT*))
ELSE BEGIN ERROR(134);GATTR.TYPTR:=NIL END
END;
(*/*) RDIV: BEGIN
# IF GATTR.TYPTR = INTPTR THEN
# BEGIN GEN0(10(*FLT*));
# GATTR.TYPTR := REALPTR
# END;
# IF LATTR.TYPTR = INTPTR THEN
# BEGIN GEN0(9(*FLO*));
# LATTR.TYPTR := REALPTR
# END;
IF (LATTR.TYPTR = REALPTR)
AND (GATTR.TYPTR=REALPTR)THEN GEN0(7(*DVR*))
ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
END;
(*DIV*) IDIV: IF (LATTR.TYPTR = INTPTR)
AND (GATTR.TYPTR = INTPTR) THEN GEN0(6(*DVI*))
ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END;
(*MOD*) IMOD: IF (LATTR.TYPTR = INTPTR)
# AND (GATTR.TYPTR = INTPTR) THEN GEN0(14 )
ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END;
(*AND*) ANDOP:IF (LATTR.TYPTR = BOOLPTR)
AND (GATTR.TYPTR = BOOLPTR) THEN GEN0(4(*AND*))
ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
END (*CASE*)
ELSE GATTR.TYPTR := NIL
END (*WHILE*)
END (*TERM*) ;
BEGIN (*SIMPLEEXPRESSION*)
SIGNED := FALSE;
IF (SY = ADDOP) AND (OP IN [PLUS,MINUS]) THEN
BEGIN SIGNED := OP = MINUS; INSYMBOL END;
TERM(FSYS + [ADDOP]);
IF SIGNED THEN
BEGIN LOAD;
IF GATTR.TYPTR = INTPTR THEN GEN0(17(*NGI*))
ELSE
IF GATTR.TYPTR = REALPTR THEN GEN0(18(*NGR*))
ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
END;
WHILE SY = ADDOP DO
BEGIN LOAD; LATTR := GATTR; LOP := OP;
INSYMBOL; TERM(FSYS + [ADDOP]); LOAD;
IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN
CASE LOP OF
(*+*) PLUS:
IF (LATTR.TYPTR = INTPTR)AND(GATTR.TYPTR = INTPTR) THEN
GEN0(2(*ADI*))
ELSE
BEGIN
# IF GATTR.TYPTR = INTPTR THEN
# BEGIN GEN0(10(*FLT*));
# GATTR.TYPTR := REALPTR
# END
# ELSE
# IF LATTR.TYPTR = INTPTR THEN
# BEGIN GEN0(9(*FLO*));
# LATTR.TYPTR := REALPTR
# END;
IF (LATTR.TYPTR = REALPTR)AND(GATTR.TYPTR = REALPTR)
THEN GEN0(3(*ADR*))
ELSE IF(LATTR.TYPTR↑.FORM=POWER)
AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
GEN0(28(*UNI*))
ELSE BEGIN ERROR(134);GATTR.TYPTR:=NIL END
END;
(*-*) MINUS:
IF (LATTR.TYPTR = INTPTR)AND(GATTR.TYPTR = INTPTR) THEN
GEN0(21(*SBI*))
ELSE
BEGIN
# IF GATTR.TYPTR = INTPTR THEN
# BEGIN GEN0(10(*FLT*));
# GATTR.TYPTR := REALPTR
# END
# ELSE
# IF LATTR.TYPTR = INTPTR THEN
# BEGIN GEN0(9(*FLO*));
# LATTR.TYPTR := REALPTR
END;
IF (LATTR.TYPTR = REALPTR)AND(GATTR.TYPTR = REALPTR)
THEN GEN0(8(*SBR*))
ELSE
IF (LATTR.TYPTR↑.FORM = POWER)
AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
GEN0(5(*DIF*))
ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
END;
(*OR*) OROP:
IF(LATTR.TYPTR=BOOLPTR)AND(GATTR.TYPTR=BOOLPTR)THEN
GEN0(13(*IOR*))
ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END
END (*CASE*)
ELSE GATTR.TYPTR := NIL
END (*WHILE*)
END (*SIMPLEEXPRESSION*) ;
(** ASSIGNMENT **)
BEGIN (*EXPRESSION*)
SIMPLEEXPRESSION(FSYS + [RELOP]);
IF SY = RELOP THEN
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <= POWER THEN LOAD
ELSE LOADADDRESS;
LATTR := GATTR; LOP := OP;
# (*IN*) IF LOP = INOP THEN
# BEGIN
# IF NOT COMPTYPES(GATTR.TYPTR,INTPTR) THEN GEN0(61(*ORD*)) ;
# IF DEBUG THEN GEN3(45(*CHK*),ORD('S'),0,MAXSETEL) ;
# END ;
INSYMBOL; SIMPLEEXPRESSION(FSYS);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <= POWER THEN LOAD
ELSE LOADADDRESS;
IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN
IF LOP = INOP THEN
IF GATTR.TYPTR↑.FORM = POWER THEN
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR↑.ELSET) THEN
GEN0(11(*INN*))
ELSE BEGIN ERROR(129); GATTR.TYPTR := NIL END
ELSE BEGIN ERROR(130); GATTR.TYPTR := NIL END
ELSE
BEGIN
IF LATTR.TYPTR <> GATTR.TYPTR THEN
# IF GATTR.TYPTR = INTPTR THEN
# BEGIN GEN0(10(*FLT*));
# GATTR.TYPTR := REALPTR
# END
# ELSE
# IF LATTR.TYPTR = INTPTR THEN
# BEGIN GEN0(9(*FLO*));
# LATTR.TYPTR := REALPTR
END;
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
BEGIN LSIZE := LATTR.TYPTR↑.SIZE;
CASE LATTR.TYPTR↑.FORM OF
SCALAR:
IF LATTR.TYPTR = REALPTR THEN TYPIND := 'R'
ELSE
IF LATTR.TYPTR = BOOLPTR THEN TYPIND := 'B'
# ELSE
# IF LATTR.TYPTR = CHARPTR THEN TYPIND := 'C'
# ELSE TYPIND := 'I' ;
POINTER:
BEGIN
IF LOP IN [LTOP,LEOP,GTOP,GEOP] THEN ERROR(131);
TYPIND := 'A'
END;
POWER:
BEGIN IF LOP IN [LTOP,GTOP] THEN ERROR(132);
TYPIND := 'S'
END;
ARRAYS:
BEGIN
IF NOT STRING(LATTR.TYPTR)
AND(LOP IN[LTOP,LEOP,GTOP,GEOP])THEN ERROR(131);
TYPIND := 'M'
END;
RECORDS:
BEGIN
IF LOP IN [LTOP,LEOP,GTOP,GEOP] THEN ERROR(131);
TYPIND := 'M'
END;
FILES:
BEGIN ERROR(133); TYPIND := 'F' END
END;
CASE LOP OF
LTOP: GEN2(53(*LES*),ORD(TYPIND),LSIZE);
LEOP: GEN2(52(*LEQ*),ORD(TYPIND),LSIZE);
GTOP: GEN2(49(*GRT*),ORD(TYPIND),LSIZE);
GEOP: GEN2(48(*GEQ*),ORD(TYPIND),LSIZE);
NEOP: GEN2(55(*NEQ*),ORD(TYPIND),LSIZE);
EQOP: GEN2(47(*EQU*),ORD(TYPIND),LSIZE)
END
END
ELSE ERROR(129)
END;
GATTR.TYPTR := BOOLPTR; GATTR.KIND := EXPR
END (*SY = RELOP*)
END (*EXPRESSION*) ;
PROCEDURE ASSIGNMENT(FCP: CTP);
VAR LATTR: ATTR;
BEGIN
### MODIFYING := TRUE ;
SELECTOR(FSYS + [BECOMES],FCP);
### MODIFYING := FALSE ; VAR_MOD := VAR_MOD+1 ;
IF SY = BECOMES THEN
BEGIN
IF GATTR.TYPTR <> NIL THEN
IF (GATTR.ACCESS<>DRCT) OR (GATTR.TYPTR↑.FORM>POWER) THEN
LOADADDRESS;
LATTR := GATTR;
INSYMBOL; EXPRESSION(FSYS);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <= POWER THEN LOAD
ELSE LOADADDRESS;
IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN
BEGIN
IF COMPTYPES(REALPTR,LATTR.TYPTR)AND(GATTR.TYPTR=INTPTR)THEN
BEGIN GEN0(10(*FLT*));
GATTR.TYPTR := REALPTR
END;
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
BEGIN
# IF DEBUG THEN
# BEGIN
# ASSIGN := TRUE ; CHKBNDS(LATTR.TYPTR); ASSIGN := FALSE
# END ;
CASE LATTR.TYPTR↑.FORM OF
SCALAR,
SUBRANGE,
POINTER,
POWER: STORE(LATTR);
ARRAYS,
RECORDS: GEN1(40(*MOV*),LATTR.TYPTR↑.SIZE);
FILES: ERROR(146)
END (*CASE LATTR...*)
# END
ELSE ERROR(129)
END
END (*SY = BECOMES*)
ELSE ERROR(51)
END (*ASSIGNMENT*) ;
(** GOTOSTATEMENT COMPOUNDSTATEMENT IFSTATEMENT **)
PROCEDURE GOTOSTATEMENT;
VAR LLP: LBP; FOUND: BOOLEAN; TTOP,TTOP1: DISPRANGE;
BEGIN
IF SY = INTCONST THEN
BEGIN
FOUND := FALSE; TTOP := TOP;
# WHILE DISPLAY[TTOP].OCCUR <> BLCK DO TTOP := TTOP - 1;
# TTOP1 := TTOP;
# REPEAT
LLP := DISPLAY[TTOP].FLABEL;
WHILE (LLP <> NIL) AND NOT FOUND DO
WITH LLP↑ DO
IF LABVAL = VAL.IVAL THEN
BEGIN FOUND := TRUE;
IF TTOP = TTOP1 THEN
BEGIN
GENUJPFJP(57(*UJP*),LABNAME) ;
"CTR" CTREMIT(CTRGOTO, 0, LINECOUNT, 0, LINECOUNT)
END
ELSE (*GOTO LEADS OUT OF PROCEDURE*) ERROR(398)
END
ELSE LLP := NEXTLAB;
TTOP := TTOP - 1
UNTIL FOUND OR (TTOP = 0);
IF NOT FOUND THEN ERROR(167);
INSYMBOL
END
ELSE ERROR(15)
END (*GOTOSTATEMENT*) ;
PROCEDURE COMPOUNDSTATEMENT;
BEGIN
REPEAT
REPEAT STATEMENT(FSYS + [SEMICOLON,ENDSY])
UNTIL NOT (SY IN STATBEGSYS);
TEST := SY <> SEMICOLON;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13)
END (*COMPOUNDSTATEMENET*) ;
PROCEDURE IFSTATEMENT;
VAR LCIX1,LCIX2: INTEGER;
"CTR" FIRSTLN, MIDLN : INTEGER; CTRNO : CTRRANGE;
BEGIN EXPRESSION(FSYS + [THENSY]);
GENLABEL(LCIX1); GENFJP(LCIX1);
IF SY = THENSY THEN INSYMBOL ELSE ERROR(52);
"CTR" FIRSTLN := LINECOUNT; CTRNO := CTRGEN;
"CTR" (*** COUNTER HERE ***)
STATEMENT(FSYS + [ELSESY]);
IF SY = ELSESY THEN
BEGIN GENLABEL(LCIX2); GENUJPFJP(57(*UJP*),LCIX2);
PUTLABEL(LCIX1);
INSYMBOL;
"CTR" MIDLN := LINECOUNT ;
STATEMENT(FSYS);
PUTLABEL(LCIX2)
END
ELSE
BEGIN
PUTLABEL(LCIX1) ;
"CTR" MIDLN := 0;
END ;
"CTR" CTREMIT(CTRIF, CTRNO, FIRSTLN, MIDLN, LINECOUNT)
END (*IFSTATEMENT*) ;
(** CASESTATEMENT REPEATSTATEMENT WHILESTATEMENT **)
PROCEDURE CASESTATEMENT;
LABEL 1;
TYPE CIP = ↑CASEINFO;
CASEINFO = PACKED
RECORD NEXT: CIP;
CSSTART: INTEGER;
CSLAB: INTEGER
END;
# # VAR LSP,LSP1: STP; FSTPTR,LPT1,LPT2,LPT3: CIP; LVAL,LVAL1: VALU;
# LADDR, LCIX, LCIX1, UBND, LBND: ADDRRANGE ;
# LMIN, LMAX : INTEGER ;
"CTR" FIRSTLN : INTEGER; TEMPLN : INTEGER;
"CTR" CTRCASES : INTEGER; CTRNO : CTRRANGE;
BEGIN EXPRESSION(FSYS + [OFSY,COMMA,COLON]);
# LOAD ; " ALIGN(LC,INTSIZE) ; LLC := LC ; "
# LSP := GATTR.TYPTR;
# IF LSP <> NIL THEN
# IF (LSP↑.FORM <> SCALAR) OR (LSP = REALPTR) THEN
# BEGIN ERROR(144); LSP := NIL END
# ELSE IF NOT COMPTYPES(LSP,INTPTR) THEN GEN0(61(*ORD*)) ;
# IF DEBUG THEN CHKBNDS(GATTR.TYPTR) ;
IF SY = OFSY THEN INSYMBOL ELSE ERROR(8);
# FSTPTR := NIL ; GENLABEL(LBND) ; GENLABEL(UBND) ;
# GENLABEL(LCIX) ; GENLABEL(LADDR);
# (* WE SHOULD HAVE: LADDR = LCIX+1 = UBND+2 = LBND+3 HERE *)
# GENUJPFJP(44 (*XJP*), LBND) ; "GENCASE(LBND,UBND,LCIX) ; "
"CTR" FIRSTLN := LINECOUNT; CTRCASES := 0;
REPEAT
LPT3 := NIL; GENLABEL(LCIX1);
# IF NOT(SY IN [SEMICOLON,ENDSY]) THEN
# BEGIN
REPEAT CONSTANT(FSYS + [COMMA,COLON,DOTDOT],LSP1,LVAL);
IF LSP <> NIL THEN
IF COMPTYPES(LSP,LSP1) THEN
# # BEGIN LVAL1.IVAL := LVAL.IVAL ;
# # IF SY = DOTDOT THEN
# # BEGIN INSYMBOL ;
# # CONSTANT(FSYS+[COMMA,COLON],LSP1,LVAL1)
# # END ;
# # IF COMPTYPES(LSP,LSP1) THEN
# # FOR LMIN := LVAL.IVAL TO LVAL1.IVAL DO
BEGIN LPT1 := FSTPTR; LPT2 := NIL;
WHILE LPT1 <> NIL DO
WITH LPT1↑ DO
BEGIN
IF CSLAB <= LMIN THEN
BEGIN
IF CSLAB = LMIN THEN ERROR(156);
GOTO 1
END;
LPT2 := LPT1; LPT1 := NEXT
END;
1: NEW(LPT3);
WITH LPT3↑ DO
BEGIN NEXT := LPT1; CSLAB := LMIN ;
CSSTART := LCIX1
END;
IF LPT2 = NIL THEN FSTPTR := LPT3
ELSE LPT2↑.NEXT := LPT3
END
ELSE ERROR(147);
END ;
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = COLON THEN INSYMBOL ELSE ERROR(5);
PUTLABEL(LCIX1);
"CTR" TEMPLN := LINECOUNT; (*** COUNTER HERE ***)
"CTR" CTRNO := CTRGEN; CTRCASES := CTRCASES+1 ;
REPEAT STATEMENT(FSYS + [SEMICOLON])
UNTIL NOT (SY IN STATBEGSYS);
IF LPT3 <> NIL THEN
GENUJPFJP(57(*UJP*),LADDR);
"CTR" CTREMIT(CTRCASE, CTRNO, TEMPLN, 0, LINECOUNT);
# END ;
TEST := SY <> SEMICOLON;
IF NOT TEST THEN INSYMBOL ;
UNTIL TEST;
IF FSTPTR <> NIL THEN
BEGIN LMAX := FSTPTR↑.CSLAB;
(*REVERSE POINTERS*)
LPT1 := FSTPTR; FSTPTR := NIL;
REPEAT LPT2 := LPT1↑.NEXT; LPT1↑.NEXT := FSTPTR;
FSTPTR := LPT1; LPT1 := LPT2
UNTIL LPT1 = NIL;
LMIN := FSTPTR↑.CSLAB;
# # END
# # ELSE BEGIN LMIN := 1 ; LMAX := 0 END ;
# GENDEF(LBND,LMIN) ; GENDEF(UBND,LMAX) ; PUTLABEL(LCIX) ;
IF LMAX - LMIN < CIXMAX THEN
# BEGIN
# # IF FSTPTR <> NIL THEN
REPEAT
WITH FSTPTR↑ DO
BEGIN
WHILE CSLAB > LMIN DO
BEGIN GENUJPFJP(57(*UJP*),LADDR); LMIN:=LMIN+1 END;
GENUJPFJP(57(*UJP*),CSSTART);
FSTPTR := NEXT; LMIN := LMIN + 1
END
UNTIL FSTPTR = NIL;
PUTLABEL(LADDR) ;
"CTR" CTREMIT(CTRCASE, 0, FIRSTLN, CTRCASES, LINECOUNT);
END
ELSE ERROR(157) ;
IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13)
END (*CASESTATEMENT*) ;
PROCEDURE REPEATSTATEMENT;
VAR LADDR: INTEGER;
"CTR" FIRSTLN : INTEGER; CTRNO : CTRRANGE;
BEGIN GENLABEL(LADDR); PUTLABEL(LADDR);
"CTR" FIRSTLN := LINECOUNT; CTRNO := CTRGEN;
"CTR" (*** COUNTER HERE ***)
REPEAT
REPEAT STATEMENT(FSYS + [SEMICOLON,UNTILSY])
UNTIL NOT (SY IN STATBEGSYS);
TEST := SY <> SEMICOLON;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = UNTILSY THEN
BEGIN INSYMBOL; EXPRESSION(FSYS); GENFJP(LADDR) ;
"CTR" CTREMIT(CTRREPEAT, CTRNO, FIRSTLN, 0, LINECOUNT)
END
ELSE ERROR(53)
END (*REPEATSTATEMENT*) ;
PROCEDURE WHILESTATEMENT;
VAR LADDR, LCIX: INTEGER;
"CTR" FIRSTLN : INTEGER; CTRNO : CTRRANGE;
BEGIN GENLABEL(LADDR); PUTLABEL(LADDR);
EXPRESSION(FSYS + [DOSY]); GENLABEL(LCIX); GENFJP(LCIX);
IF SY = DOSY THEN INSYMBOL ELSE ERROR(54);
"CTR" FIRSTLN := LINECOUNT; CTRNO := CTRGEN;
(*** COUNTER HERE ***)
STATEMENT(FSYS); GENUJPFJP(57(*UJP*),LADDR); PUTLABEL(LCIX) ;
"CTR" CTREMIT(CTRWHILE, CTRNO, FIRSTLN, 0, LINECOUNT);
END (*WHILESTATEMENT*) ;
(** FORSTATEMENT WITHSTATEMENT **)
PROCEDURE FORSTATEMENT;
VAR LATTR: ATTR; LSP: STP; LSY: SYMBOL;
# LCIX, LADDR: LABELRNG ; LLC : ADDRRANGE ;
"CTR" FIRSTLN : INTEGER; CTRNO : CTRRANGE;
BEGIN
IF SY = IDENT THEN
BEGIN SEARCHID([VARS],LCP);
WITH LCP↑, LATTR DO
# BEGIN TYPTR := IDTYPE; KIND := VARBL; BTYPE := TYPTR ;
IF VKIND = ACTUAL THEN
BEGIN ACCESS := DRCT; VLEVEL := VLEV;
DPLMT := VADDR ;
### IF GET_STAT THEN
### WRITE(QRR, ' #MOD', CHR( GETTYPE(BTYPE) ), ' ':2,
### ' #DIR', VLEVEL:3, DPLMT:8, ' #MND ' ) ;
END
ELSE BEGIN ERROR(155); TYPTR := NIL END
END;
IF LATTR.TYPTR <> NIL THEN
IF (LATTR.TYPTR↑.FORM > SUBRANGE)
OR COMPTYPES(REALPTR,LATTR.TYPTR) THEN
BEGIN ERROR(143); LATTR.TYPTR := NIL END;
INSYMBOL
END
ELSE
BEGIN ERROR(2); SKIP(FSYS + [BECOMES,TOSY,DOWNTOSY,DOSY]) END;
IF SY = BECOMES THEN
BEGIN INSYMBOL; EXPRESSION(FSYS + [TOSY,DOWNTOSY,DOSY]);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <> SCALAR THEN ERROR(144)
ELSE
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
BEGIN LOAD;
# IF DEBUG THEN CHKBNDS(LATTR.TYPTR) ; STORE(LATTR) ;
END
ELSE ERROR(145)
END
ELSE
BEGIN ERROR(51); SKIP(FSYS + [TOSY,DOWNTOSY,DOSY]) END;
IF SY IN [TOSY,DOWNTOSY] THEN
BEGIN LSY := SY; INSYMBOL; EXPRESSION(FSYS + [DOSY]);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM <> SCALAR THEN ERROR(144)
ELSE
IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN
# BEGIN LOAD; IF DEBUG THEN CHKBNDS(LATTR.TYPTR) ;
(*EJG 13NOV78*) IF NOT COMPTYPES(LATTR.TYPTR,INTPTR) THEN GEN0(61(*ORD*));
# ALIGN(LC,INTSIZE) ; LLC := LC ;
# GEN3(56(*STR*),ORD('I'),LEVEL,LLC);
# GATTR := LATTR; LOAD;
(*EJG 13NOV78*) IF NOT COMPTYPES(LATTR.TYPTR,INTPTR) THEN GEN0(61(*ORD*));
# GEN3(54(*LOD*),ORD('I'),LEVEL,LLC);
# LC := LC + INTSIZE;
# IF LC > LCMAX THEN LCMAX := LC;
# IF LSY = TOSY THEN GEN2(52(*LEQ*),ORD('I'),1)
# ELSE GEN2(48(*GEQ*),ORD('I'),1);
END
ELSE ERROR(145)
END
ELSE BEGIN ERROR(55); SKIP(FSYS + [DOSY]) END;
# GENLABEL(LADDR) ; GENLABEL(LCIX); GENUJPFJP(33(*FJP*),LCIX);
# PUTLABEL(LADDR) ; (*BEGINNING OF THE FOR 'LOOP'*)
IF SY = DOSY THEN INSYMBOL ELSE ERROR(54);
"CTR" FIRSTLN := LINECOUNT; CTRNO := CTRGEN;
(*** COUNTER HERE ***)
STATEMENT(FSYS);
# GATTR := LATTR ; LOAD ;
IF NOT COMPTYPES(LATTR.TYPTR,INTPTR) THEN GEN0(61(*ORD*));(*EJG13NOV*)
# GEN3(54(*LOD*),ORD('I'),LEVEL,LLC) ;
# GEN2(55(*NEQ*),ORD('I'),1) ; GENUJPFJP(33(*FJP*),LCIX) ;
# GATTR := LATTR; LOAD;
# IF LSY = TOSY THEN GEN2(23(*INC*),GETTYPE(GATTR.BTYPE),1)
# ELSE GEN2(22(*DEC*),GETTYPE(GATTR.BTYPE),1);
# IF DEBUG THEN CHKBNDS(LATTR.TYPTR) ;
STORE(LATTR); GENUJPFJP(57(*UJP*),LADDR); PUTLABEL(LCIX);
LC := LLC ;
"CTR" CTREMIT(CTRFOR, CTRNO, FIRSTLN, 0, LINECOUNT);
END (*FORSTATEMENT*) ;
PROCEDURE WITHSTATEMENT;
# VAR LCP: CTP; LCNT: DISPRANGE; LLC: ADDRRANGE;
BEGIN LCNT := TOP ; LLC := LC ;
REPEAT
IF SY = IDENT THEN
BEGIN SEARCHID([VARS,FIELD],LCP); INSYMBOL END
ELSE BEGIN ERROR(2); LCP := UVARPTR END;
SELECTOR(FSYS + [COMMA,DOSY],LCP);
IF GATTR.TYPTR <> NIL THEN
IF GATTR.TYPTR↑.FORM = RECORDS THEN
IF TOP < DISPLIMIT THEN
# BEGIN TOP := TOP + 1;
WITH DISPLAY[TOP] DO
BEGIN FNAME := GATTR.TYPTR↑.FSTFLD;
FLABEL := NIL
END;
IF GATTR.ACCESS = DRCT THEN
WITH DISPLAY[TOP] DO
BEGIN OCCUR := CREC; CLEV := GATTR.VLEVEL;
CDSPL := GATTR.DPLMT
END
ELSE
# BEGIN LOADADDRESS; ALIGN(LC,PTRSIZE) ;
# GEN3(56(*STR*),ORD('A'),LEVEL,LC);(*=GETTYPE(GAT.TYP)*)
WITH DISPLAY[TOP] DO
BEGIN OCCUR := VREC; VDSPL := LC END;
# LC := LC + PTRSIZE;
IF LC > LCMAX THEN LCMAX := LC
END
END
ELSE ERROR(250)
ELSE ERROR(140);
TEST := SY <> COMMA;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = DOSY THEN INSYMBOL ELSE ERROR(54);
STATEMENT(FSYS);
# TOP := LCNT ; LC := LLC ;
END (*WITHSTATEMENT*) ;
BEGIN (*STATEMENT*)
IF SY = INTCONST THEN (*LABEL*)
# BEGIN TTOP := TOP ;
# WHILE DISPLAY[TTOP].OCCUR <> BLCK DO TTOP := TTOP-1 ;
# LLP := DISPLAY[TTOP].FLABEL;
WHILE LLP <> NIL DO
WITH LLP↑ DO
IF LABVAL = VAL.IVAL THEN
BEGIN IF DEFINED THEN ERROR(165);
PUTLABEL(LABNAME); DEFINED := TRUE;
"CTR" CTRNO := CTRGEN;
"CTR" CTREMIT(CTRLBL, CTRNO, LINECOUNT, 0, LINECOUNT);
"CTR" (*** COUNTER HERE ***)
GOTO 1
END
ELSE LLP := NEXTLAB;
ERROR(167);
1: INSYMBOL;
IF SY = COLON THEN INSYMBOL ELSE ERROR(5)
END;
IF NOT (SY IN FSYS + [IDENT]) THEN
BEGIN ERROR(6); SKIP(FSYS) END;
IF SY IN STATBEGSYS + [IDENT] THEN
BEGIN
CASE SY OF
IDENT: BEGIN SEARCHID([VARS,FIELD,FUNC,PROC],LCP); INSYMBOL;
IF LCP↑.KLASS = PROC THEN CALL(FSYS,LCP)
ELSE ASSIGNMENT(LCP)
END;
BEGINSY: BEGIN INSYMBOL; COMPOUNDSTATEMENT END;
GOTOSY: BEGIN INSYMBOL; GOTOSTATEMENT END;
IFSY: BEGIN INSYMBOL; IFSTATEMENT END;
CASESY: BEGIN INSYMBOL; CASESTATEMENT END;
WHILESY: BEGIN INSYMBOL; WHILESTATEMENT END;
REPEATSY: BEGIN INSYMBOL; REPEATSTATEMENT END;
FORSY: BEGIN INSYMBOL; FORSTATEMENT END;
WITHSY: BEGIN INSYMBOL; WITHSTATEMENT END
END;
IF NOT (SY IN [SEMICOLON,ENDSY,ELSESY,UNTILSY]) THEN
BEGIN ERROR(6); SKIP(FSYS) END
END
END (*STATEMENT*) ;
BEGIN (*BODY*)
# IF FPROCP <> NIL THEN
# BEGIN ENTNAME := FPROCP↑.PFNAME ; PROCNAME := FPROCP↑.NAME ; END
# ELSE PROCNAME := '$MAINBLK ' ;
# GENCUPENT(32(*ENT*),PROCTYPE(FPROCP),SEGSIZE,ENTNAME,PROCNAME) ;
###
### NEW(CALL_HEAD) ;
### CALL_HEAD↑.NAME := BLANK12 ; CALL_HEAD↑.NXT := NIL ;
### LOCAL_CALL := FALSE ; MODIFYING := FALSE ;
### VAR_REF := 0 ; VAR_MOD := 0 ;
### WRITELN(QRR, '#BGN ', PROCNAME, LEVEL:4) ;
###
#
# IF FPROCP = NIL THEN (* ENTERING MAIN BLOCK *)
BEGIN
SAVEID := ID;
WHILE FEXTFILEP <> NIL DO
BEGIN
WITH FEXTFILEP↑ DO
BEGIN ID := FILENAME;
PRTERR := FALSE ; SEARCHID([VARS],LLCP); PRTERR := TRUE ;
IF LLCP <> NIL THEN
IF LLCP↑.IDTYPE↑.FORM <> FILES THEN
LLCP := NIL;
# IF LLCP = NIL THEN
# BEGIN
# WRITELN('**** UNDECLARED EXTERNAL FILE:':40, ID:10);
# ERROR(398) ;
# END
# ELSE (* OPEN THE FILES REQUESTED ABOVE *)
# WITH LLCP↑ DO
# BEGIN
# IF GEBCDFIL THEN GEN2(50(*LDA*),1,VADDR+1000)
# ELSE GEN2(50(*LDA*),1,VADDR) ;
# GEN1(30(*CSP*),31(*SIO*)) ;
# IF ODD(VADDR) THEN GEN1(30(*CSP*),4(*REW*))
# ELSE GEN1(30(*CSP*),3(*RES*)) ;
# GEN1(30(*CSP*),30(*EIO*)) ;
# END ;
END;
FEXTFILEP := FEXTFILEP↑.NEXTFILE
END;
ID := SAVEID;
"CTR" IF CTROPTION THEN
"CTR" BEGIN
"CTR" GENLABEL(CTRCNTLBL) ; GENUJPFJP(38(*CTS*), CTRCNTLBL) ;
"CTR" END ;
END (* PROCESSING MAIN BLOCK *)
ELSE (* FPROCP <> NIL ==> COPY MULTIPLE VALUES INTO LOCAL CELLS*)
# BEGIN LLC1 := LCAFTMST ;
# IF FPROCP↑.SAVEFP THEN LLC1 := LCAFTMST+FPSAVEAREA ;
LCP := FPROCP↑.NEXT;
WHILE LCP <> NIL DO
WITH LCP↑ DO
BEGIN
IF KLASS = VARS THEN
IF IDTYPE <> NIL THEN
# IF VKIND = FORMAL THEN (* VAR PARAMETER *)
# BEGIN ALIGN(LLC1,PTRSIZE) ;
# LLC1 := LLC1+PTRSIZE ;
# END
# ELSE (* VKIND = ACTUAL *)
# IF IDTYPE↑.FORM > POWER THEN
# BEGIN
# ALIGN(LLC1,PTRSIZE) ;
# GEN2(50(*LDA*),LEVEL,VADDR);
# GEN3(54(*LOD*),ORD('A'),LEVEL,LLC1);
# GEN1(40(*MOV*),IDTYPE↑.SIZE);
# LLC1 := LLC1 + PTRSIZE
# END
# ELSE (* FORM <= POWER *)
# BEGIN
# ALIGN(LLC1,IDTYPE↑.ALN) ; LLC1 := LLC1 + IDTYPE↑.SIZE ;
# END ;
LCP := LCP↑.NEXT;
END;
END;
"CTR" FIRSTLN := LINECOUNT; CTRNO := CTRGEN;
"CTR" (*** COUNTER HERE ***)
LCMAX := LC;
(* COMPILE THE STATEMENTS WITHIN THIS BLOCK (BODY) *)
REPEAT
REPEAT STATEMENT(FSYS + [SEMICOLON,ENDSY])
UNTIL NOT (SY IN STATBEGSYS);
TEST := SY <> SEMICOLON;
IF NOT TEST THEN INSYMBOL
UNTIL TEST;
IF SY = ENDSY THEN "INSYMBOL" (*PEG*)
BEGIN
ENDFLG := TRUE;
INSYMBOL;
ENDFLG := FALSE;
END (*PEG*)
ELSE ERROR(13);
LLP := DISPLAY[TOP].FLABEL; (*TEST FOR UNDEFINED LABELS*)
WHILE LLP <> NIL DO
WITH LLP↑ DO
BEGIN
IF NOT DEFINED THEN
BEGIN
# WRITELN(OUTPUT,'**** UNDEF. LABEL:':28,LABVAL); ERROR(168) ;
END;
LLP := NEXTLAB
END;
"CTR" CTREMIT(CTRPROC, CTRNO, FIRSTLN, 0, LINECOUNT);
"CTR" IF FPROCP = NIL THEN (* RESET COUNTERS *)
"CTR" BEGIN
"CTR" CTREMIT(CTRPROC, 0, 0, 0, 0); (* EOF FOR COUNTER TABLE *)
"CTR" IF ODD(CTRCNT) THEN CTRCNT := CTRCNT+1 ;
"CTR" IF CTROPTION THEN GENDEF(CTRCNTLBL, CTRCNT) ;
"CTR" END ;
# GEN1(42(*RET*),PROCTYPE(FPROCP)); ALIGN(LCMAX,MXDATASZE) ;PRTIC := FALSE ;
# IF PRCODE THEN
BEGIN GENDEF(SEGSIZE,LCMAX) ;
IF FPROCP = NIL THEN GEN0(43(*STP*) ) ;
END ;
"IF (FPROCP = NIL) AND PRTABLES THEN PRINTTABLES(TRUE) "
###
### CALL_LVL[LOCAL_CALL] := CALL_LVL[LOCAL_CALL]+1 ;
### WRITELN(QRR) ;
### WRITE(QRR, '#PROC ':8, PROCNAME:IDLNGTH, LOCAL_CALL:4, IC:6, LCMAX:10,
### ' REF./MOD. RATIO:', VAR_MOD:4, VAR_MOD+VAR_REF:6) ;
### IF (VAR_MOD+VAR_REF) = 0 THEN WRITELN(QRR,0.0:10)
### ELSE WRITELN(QRR, VAR_MOD/(VAR_MOD+VAR_REF):10) ;
### WHILE CALL_HEAD↑.NXT <> NIL DO
### BEGIN
### WRITE(QRR, ' ', CALL_HEAD↑.NAME, CALL_HEAD↑.LVL:3, CALL_HEAD↑.CNT: 4);
### CALL_HEAD := CALL_HEAD↑.NXT ;
### END ;
### WRITELN(QRR) ; WRITELN(QRR, '#END') ;
###
# OLDIC := OLDIC+ IC ; IC := 0 ; (* RESET IC FOR NEXT PROC *)
END (*BODY*) ;
"S1"
(** MKNAME PROGRAMME STDNAMES ENTERSTDTYPES **)
"S1" PROCEDURE MKNAME(VAR ALB: ALPHA; NLB: INTEGER ) ;
"S1" VAR I, J: INTEGER ;
"S1"
"S1" BEGIN
"S1" I := 1 ;
"S1" WHILE (I < 6) AND (ALB[I] <> ' ') DO
"S1" BEGIN IF ALB[I] = '_' THEN ALB[I] := '$' ; I := I+1 END ;
"S1" FOR J := 8 DOWNTO I DO
"S1" BEGIN
"S1" ALB[J] := CHR( ORD('0')+ NLB MOD 10 ) ;
"S1" NLB := NLB DIV 10 ;
"S1" END ;
"S1" END (*MKNAME*) ;
BEGIN (*BLOCK*)
" DP := TRUE;" GENLABEL(SEGSIZE) ;
REPEAT
IF SY = LABELSY THEN
BEGIN INSYMBOL; LABELDECLARATION END;
IF SY = CONSTSY THEN
BEGIN INSYMBOL; CONSTDECLARATION END;
IF SY = TYPESY THEN
BEGIN INSYMBOL; TYPEDECLARATION END;
IF SY = VARSY THEN
BEGIN INSYMBOL; VARDECLARATION END;
"S1"
"S1" WRITE(PRR, ' SST ', CHR( PROCTYPE(FPROCP) ):1, ' ') ;
"S1" IF FPROCP = NIL THEN
"S1""LCW" WRITELN(PRR, '$MAINBLK', 1:8, 0:8, 0:8, LC-LASTFILBUF:8, 0:8)
"S1" ELSE
"S1" WITH FPROCP↑ DO
"S1" BEGIN ID := NAME ; MKNAME(ID, PFNAME) ; ALIGN(LC,MXDATASZE) ;
"S1""LCW" WRITELN(PRR, ID:8, PFLEV+1:8, FPRMSZE:8, SPRMSZE:8,
"S1""LCW" LC-LCAFTMST-FPRMSZE-SPRMSZE:8, RPRMSZE:8) ;
"S1" END ;
"S1"
WHILE SY IN [PROCSY,FUNCSY] DO
BEGIN LSY := SY; INSYMBOL; PROCDECLARATION(LSY) END;
IF SY <> BEGINSY THEN
BEGIN ERROR(18); SKIP(FSYS) END
UNTIL SY IN STATBEGSYS;
DP := FALSE;
IF SY = BEGINSY THEN INSYMBOL ELSE ERROR(17);
REPEAT BODY(FSYS + [CASESY]);
IF SY <> FSY THEN
BEGIN ERROR(6); SKIP(FSYS + [FSY]) END
UNTIL (SY = FSY) OR (SY IN BLOCKBEGSYS);
# DP := TRUE ;
END (*BLOCK*) ;
PROCEDURE PROGRAMME(FSYS:SETOFSYS);
VAR EXTFP:EXTFILEP;
BEGIN
### REWRITE(QRR) ; (* USED FOR EXTRA INFO ABOUT PROGRAM *)
"E" REWRITE(SYMTBL);
### CALL_LVL[FALSE] := 0 ; CALL_LVL[TRUE] := 0 ;
IF SY = PROGSY THEN
BEGIN INSYMBOL; IF SY <> IDENT THEN ERROR(2); INSYMBOL;
IF NOT (SY IN [LPARENT,SEMICOLON]) THEN ERROR(14);
IF SY = LPARENT THEN
BEGIN
REPEAT INSYMBOL;
IF SY = IDENT THEN
BEGIN NEW(EXTFP);
WITH EXTFP↑ DO
BEGIN FILENAME := ID; NEXTFILE := FEXTFILEP ;
GEBCDFIL := EBCDFLG ; EBCDFLG := FALSE
END;
FEXTFILEP := EXTFP;
INSYMBOL;
IF NOT ( SY IN [COMMA,RPARENT] ) THEN ERROR(20)
END
ELSE ERROR(2)
UNTIL SY <> COMMA;
IF SY <> RPARENT THEN ERROR(4);
INSYMBOL
END;
IF SY <> SEMICOLON THEN ERROR(14)
ELSE INSYMBOL;
END;
"E" WRITELN(SYMTBL,'% $MAINBLK 0');
REPEAT BLOCK(FSYS,PERIOD,NIL);
IF SY <> PERIOD THEN ERROR(21)
UNTIL SY = PERIOD ;
### WRITELN(QRR,'#HLT CALL_RATIO', CALL_LVL[TRUE]:4, CALL_LVL[FALSE]:4,
### CALL_LVL[TRUE]+CALL_LVL[FALSE]:4) ;
# IF ERRINX > 0 THEN PRINTERROR ;
END (*PROGRAMME*) ;
PROCEDURE STDNAMES;
BEGIN
NA[ 1] := 'FALSE '; NA[ 2] := 'TRUE ';
NA[ 5] := 'GET '; NA[ 6]:= 'PUT ';
NA[ 7] := 'RESET '; NA[ 8] := 'REWRITE '; NA[ 9]:= 'READ ';
NA[10] := 'WRITE '; NA[11] := 'PACK '; NA[12]:= 'UNPACK ';
NA[13] := 'NEW '; NA[14] := 'RELEASE '; NA[15]:= 'READLN ';
NA[16] := 'WRITELN '; NA[17] := 'MARK '; NA[18]:= 'TRAP ';
NA[19] := 'EXIT ';
NA[20] := 'ABS '; NA[21] := 'SQR '; NA[22]:= 'TRUNC ';
NA[23] := 'ODD '; NA[24] := 'ORD '; NA[25]:= 'CHR ';
NA[26] := 'PRED '; NA[27] := 'SUCC '; NA[28]:= 'CLOCK ';
NA[29] := 'EOF '; NA[30] := 'EOLN ';
NA[31] := 'SIN '; NA[32] := 'COS '; NA[33]:= 'EXP ';
NA[34] := 'SQRT '; NA[35] := 'LN '; NA[36]:= 'ARCTAN ';
# NA[39] := 'INPUT '; NA[40] := 'OUTPUT '; NA[41]:= 'PRD ';
# NA[42] := 'PRR '; NA[43] := 'QRD '; NA[44]:= 'QRR ';
END (*STDNAMES*) ;
PROCEDURE ENTERSTDTYPES;
VAR SP: STP;
BEGIN (*TYPE UNDERLIEING:*)
(*******************)
NEW(INTPTR,SCALAR,STANDARD); (*INTEGER*)
WITH INTPTR↑ DO
BEGIN SIZE := INTSIZE; ALN := INTSIZE ;
FORM := SCALAR; SCALKIND := STANDARD END;
NEW(REALPTR,SCALAR,STANDARD); (*REAL*)
WITH REALPTR↑ DO
" BEGIN SIZE := REALSIZE; ALN := MXDATASZE ;" (*LCW*)
BEGIN SIZE := REALSIZE; ALN := REALSIZE ; (*LCW *)
FORM := SCALAR; SCALKIND := STANDARD END;
NEW(CHARPTR,SCALAR,STANDARD); (*CHAR*)
WITH CHARPTR↑ DO
BEGIN SIZE := CHARSIZE; ALN := CHARSIZE ;
FORM := SCALAR; SCALKIND := STANDARD END;
NEW(BOOLPTR,SCALAR,DECLARED); (*BOOLEAN*)
WITH BOOLPTR↑ DO
BEGIN SIZE := BOOLSIZE; ALN := BOOLSIZE ;
FORM := SCALAR; SCALKIND := DECLARED END;
NEW(NILPTR,POINTER); (*NIL*)
WITH NILPTR↑ DO
BEGIN ELTYPE := NIL; SIZE := PTRSIZE; ALN := PTRSIZE ;
FORM := POINTER END;
NEW(TEXTPTR,FILES); (*TEXT*)
WITH TEXTPTR↑ DO
BEGIN FILTYPE := CHARPTR; SIZE := CHARSIZE; ALN := CHARSIZE ;
FORM := FILES END ;
NEW(ALFAPTR,ARRAYS); (*ALFA*)
WITH ALFAPTR↑ DO
BEGIN AELTYPE := CHARPTR; SIZE := 10*CHARSIZE ; ALN := CHARSIZE ;
FORM := ARRAYS ;
NEW(INXTYPE,SUBRANGE) ;
INXTYPE↑.RANGETYPE := INTPTR;
INXTYPE↑.MIN.IVAL := 1; INXTYPE↑.MAX.IVAL := 10;
(* OTHER FIELDS ARE IRRELEVENT !!! *)
END ;
END (*ENTERSTDTYPES*) ;
(** ENTSTDNAMES ENTERUNDECL **)
PROCEDURE ENTSTDNAMES;
VAR CP,CP1: CTP; I: INTEGER;
BEGIN (*NAME:*)
(*******)
NEW(CP,TYPES); (*INTEGER*)
WITH CP↑ DO
BEGIN NAME := 'INTEGER '; IDTYPE := INTPTR; KLASS := TYPES END;
ENTERID(CP);
NEW(CP,TYPES); (*REAL*)
WITH CP↑ DO
BEGIN NAME := 'REAL '; IDTYPE := REALPTR; KLASS := TYPES END;
ENTERID(CP);
NEW(CP,TYPES); (*CHAR*)
WITH CP↑ DO
BEGIN NAME := 'CHAR '; IDTYPE := CHARPTR; KLASS := TYPES END;
ENTERID(CP);
NEW(CP,TYPES); (*BOOLEAN*)
WITH CP↑ DO
BEGIN NAME := 'BOOLEAN '; IDTYPE := BOOLPTR; KLASS := TYPES END;
ENTERID(CP);
NEW(CP,TYPES); (*CHAR*)
WITH CP↑ DO
BEGIN NAME := 'TEXT '; IDTYPE := TEXTPTR; KLASS := TYPES END;
ENTERID(CP);
NEW(CP,TYPES); (*ALFA*)
WITH CP↑ DO
BEGIN NAME := 'ALFA '; IDTYPE := ALFAPTR ; ; KLASS := TYPES END ;
ENTERID(CP);
CP1 := NIL;
FOR I := 1 TO 2 DO
BEGIN NEW(CP,KONST); (*FALSE,TRUE*)
WITH CP↑ DO
BEGIN NAME := NA[I]; IDTYPE := BOOLPTR;
NEXT := CP1; VALUES.IVAL := I - 1; KLASS := KONST
END;
ENTERID(CP); CP1 := CP
END;
BOOLPTR↑.FCONST := CP;
NEW(CP,KONST); (*NIL*)
WITH CP↑ DO
BEGIN NAME := 'NIL '; IDTYPE := NILPTR;
NEXT := NIL; VALUES.IVAL := 0; KLASS := KONST
END;
ENTERID(CP);
# FOR I := 39 TO 44 DO
BEGIN NEW(CP,VARS); (*INPUT,OUTPUT*)
WITH CP↑ DO (*PRD,PRR*)
BEGIN NAME := NA[I]; IDTYPE := TEXTPTR; (*QRD,QRR*)
KLASS := VARS; VKIND := ACTUAL; NEXT := NIL; VLEV := 1;
# VADDR := FIRSTFILBUF+(I-39)*CHARSIZE ; EBCD := FALSE ;
END;
ENTERID(CP)
END;
# FOR I := 5 TO 36 DO (*GET...ATAN*)
## # BEGIN NEW(CP,PROC,STANDARD); (*GET,PUT,RESET*)
## # WITH CP↑ DO (*REWRITE,READ*)
## # BEGIN NAME := NA[I]; IDTYPE := NIL; (*WRITE,PACK*)
## # NEXT := NIL; KEY := I - 4; (*UNPACK,PACK*)
## # IF I <= 19 THEN KLASS := PROC ELSE KLASS := FUNC ;
## # PFDECKIND := STANDARD (*READLN,WRITELN*)
## # END; (*NEW,DISPOSE*)
## # ENTERID(CP) (*TRAP*)
## # END;
# " FOR I := 20 TO 30 DO
BEGIN NEW(CP,FUNC,STANDARD); (*ABS,SQR,TRUNC*)
WITH CP↑ DO (*ODD,ORD,CHR*)
BEGIN NAME := NA[I]; IDTYPE := NIL; (*PRED,SUCC*)
NEXT := NIL; KEY := I - 19; (*CLOCK,EOF,EOLN *)
KLASS := FUNC; PFDECKIND := STANDARD
END;
ENTERID(CP)
END;
NEW(CP,VARS); (*PARAMETER OF PREDECLARED FUNCTIONS*)
WITH CP↑ DO
BEGIN NAME := BLANK12; IDTYPE := REALPTR; KLASS := VARS;
VKIND := ACTUAL; NEXT := NIL; VLEV := 1; VADDR := 0
END;
# FOR I := 31 TO 37 DO
BEGIN NEW(CP1,FUNC,DECLARED,ACTUAL); (*SIN,COS,EXP,SQRT*)
WITH CP1↑ DO (*LN,ARCTAN,EXIT*)
BEGIN NAME := NA[I]; IDTYPE := REALPTR; NEXT := CP;
FWDECL := FALSE; EXTRN := TRUE; PFLEV := 0; PFNAME := I - 16;
KLASS := FUNC; PFDECKIND := DECLARED; PFKIND := ACTUAL
END;
ENTERID(CP1)
END;
# WITH CP1↑ DO (*FIXUPS FOR EXIT PROCEDURE*)
# BEGIN IDTYPE := NIL; NEXT := CP; KLASS := PROC END;
# NEW(CP,VARS); (*PARAMETER OF EXIT ROUTINE*)
# WITH CP↑ DO
# BEGIN NAME := BLANK12; IDTYPE := INTPTR; KLASS := VARS;
# VKIND := ACTUAL; NEXT := NIL; VLEV := 1; VADDR := 0
# END; "
END (*ENTSTDNAMES*) ;
PROCEDURE ENTERUNDECL;
VAR TMPLABEL: INTEGER; (*KLUDGE FOR XSL10*)
BEGIN
NEW(UTYPPTR,TYPES);
WITH UTYPPTR↑ DO
BEGIN NAME := BLANK12; IDTYPE := NIL; KLASS := TYPES END;
NEW(UCSTPTR,KONST);
WITH UCSTPTR↑ DO
BEGIN NAME := BLANK12; IDTYPE := NIL; NEXT := NIL;
VALUES.IVAL := 0; KLASS := KONST
END;
NEW(UVARPTR,VARS);
WITH UVARPTR↑ DO
BEGIN NAME := BLANK12; IDTYPE := NIL; VKIND := ACTUAL;
NEXT := NIL; VLEV := 0; VADDR := 0; KLASS := VARS
END;
NEW(UFLDPTR,FIELD);
WITH UFLDPTR↑ DO
BEGIN NAME := BLANK12; IDTYPE := NIL; NEXT := NIL; FLDADDR := 0;
KLASS := FIELD
END;
NEW(UPRCPTR,PROC,DECLARED,ACTUAL);
WITH UPRCPTR↑ DO
BEGIN NAME := BLANK12; IDTYPE := NIL; FWDECL := FALSE;
NEXT := NIL; EXTRN := FALSE; PFLEV := 0; GENLABEL(TMPLABEL); (*XSL10*)
PFNAME := TMPLABEL; (*XSL10*)
KLASS := PROC; PFDECKIND := DECLARED; PFKIND := ACTUAL
END;
NEW(UFCTPTR,FUNC,DECLARED,ACTUAL);
WITH UFCTPTR↑ DO
BEGIN NAME := BLANK12; IDTYPE := NIL; NEXT := NIL;
FWDECL := FALSE; EXTRN := FALSE; PFLEV := 0; GENLABEL(TMPLABEL);(*XSL10*)
PFNAME := TMPLABEL; (*XSL10*)
KLASS := FUNC; PFDECKIND := DECLARED; PFKIND := ACTUAL
END
END (*ENTERUNDECL*) ;
(** INITSCALARS INITSETS INITTABLES RESWORDS SYMBOLS RATORS PROCMNEMONICS **)
PROCEDURE INITSCALARS;
VAR I:INTEGER;
BEGIN FWPTR := NIL;
PRTABLES := FALSE; LIST := TRUE; PRCODE := TRUE;
DP := TRUE; PRTERR := TRUE; ERRINX := 0;
INTLABEL := 0; KK := IDLNGTH; FEXTFILEP := NIL;
# LC := LASTFILBUF ; (*ADR. OF THE FIRST VARIABLE OF 'MAIN BLOCK'*)
(* NOTE IN THE ABOVE RESERVATION OF BUFFER STORE FOR TEXT FILES *)
OLDIC := 0; IC := 0 ; EOL := FALSE; LINECOUNT := 1; (*PEG*)
# CH := ' '; CHCNT := 0; CHCNTMAX := DEF_CHCNTMAX; (*PEG*)
GLOBTESTP := NIL;
MXINT10 := MAXINT DIV 10; "DIGMAX := REALLNGTH - 1;"
# PROCLAB := 0; ERRORCOUNT :=0 ; ASSEMBLE:= FALSE;
SEQNUMBERS := FALSE ; FOR I := 1 TO 8 DO SEQFLD[I] := ' '; (*PEG*)
# SAVEREGS := TRUE ; SAVEFPRS := TRUE ; EBCDFLG := FALSE ;
# DEBUG := FALSE ; BYTEON := FALSE ; ASSIGN := FALSE ;
# ENDFLG := FALSE; DOTFLG := FALSE ; NXTFILBUF := FIRSTFILBUF+6 ;
# PACKDATA := FALSE ; XLINK := FALSE ; (*GENERATES UNIQUE NAMES *)
"S0" " MXDATASZE := REALSIZE ; "
"S1" MXDATASZE := PTRSIZE ; (* DON'T CHANGE THIS ALONE *)
### GET_STAT := FALSE ; ASMVERB := FALSE ;
"CTR" CTRCNT := 0 ; CTROPTION := FALSE ;
FOR I := 1 TO STD_CHCNTMAX DO LINEBUF[I] := ' '; (*PEG*)
END (*INITSCALARS*) ;
PROCEDURE INITSETS;
VAR I: SETREP_INDEX; (*SETCH*)
BEGIN
CONSTBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT];
SIMPTYPEBEGSYS := [LPARENT] + CONSTBEGSYS;
TYPEBEGSYS:=[ARROW,PACKEDSY,ARRAYSY,RECORDSY,SETSY,FILESY]+SIMPTYPEBEGSYS;
TYPEDELS := [ARRAYSY,RECORDSY,SETSY,FILESY];
BLOCKBEGSYS := [LABELSY,CONSTSY,TYPESY,VARSY,PROCSY,FUNCSY,
BEGINSY];
SELECTSYS := [ARROW,PERIOD,LBRACK];
FACBEGSYS := [INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,LBRACK,NOTSY];
STATBEGSYS := [BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,FORSY,WITHSY,
CASESY];
#
# " ATOZ := ['A','B','C','D','E','F','G','H','I','J','K','L','M','N','O'] ;
# ATOZ := ATOZ + ['P','Q','R','S','T','U','V','W','X','Y','Z'] ;
# NUMERIC := ['0','1','2','3','4','5','6','7','8','9'] ; "
# ATOZ := ['A'..'Z'] ;
# NUMERIC := ['0'..'9'] ;
# ALPHANUMERIC := ATOZ + NUMERIC + ['$','_'];
#
FOR I:=0 TO SETREP_MAX DO NULL_SET[I] := [ ]; (*SETCH*)
END (*INITSETS*) ;
PROCEDURE INITTABLES;
PROCEDURE RESWORDS;
BEGIN
RW[ 1]:= 'IF '; RW[ 2]:= 'DO '; RW[ 3]:= 'OF ';
RW[ 4]:= 'TO '; RW[ 5]:= 'IN '; RW[ 6]:= 'OR ';
RW[ 7]:= 'END '; RW[ 8]:= 'FOR '; RW[ 9]:= 'VAR ';
RW[10]:= 'DIV '; RW[11]:= 'MOD '; RW[12]:= 'SET ';
RW[13]:= 'AND '; RW[14]:= 'NOT '; RW[15]:= 'THEN ';
RW[16]:= 'ELSE '; RW[17]:= 'WITH '; RW[18]:= 'GOTO ';
RW[19]:= 'CASE '; RW[20]:= 'TYPE ';
RW[21]:= 'FILE '; RW[22]:= 'BEGIN ';
RW[23]:= 'UNTIL '; RW[24]:= 'WHILE '; RW[25]:= 'ARRAY ';
RW[26]:= 'CONST '; RW[27]:= 'LABEL ';
RW[28]:= 'REPEAT '; RW[29]:= 'RECORD '; RW[30]:= 'DOWNTO ';
RW[31]:= 'PACKED '; RW[32]:= 'FORWARD '; RW[33]:= 'PROGRAM ';
RW[34]:= 'FORTRAN '; RW[35]:= 'EXTERNAL ';
RW[36]:= 'FUNCTION '; RW[37]:= 'PROCEDURE ';
FRW[1] := 1; FRW[2] := 1; FRW[3] := 7; FRW[4] := 15; FRW[5] := 22;
FRW[6] := 28; FRW[7] := 32; FRW[8] := 35; FRW[9] := 37;
# FRW[10] := 38 ; FRW[11] := 38; FRW[12] := 38; FRW[13] := 38 ;
# "SEQFLD[9] := ' '; SEQFLD[10] := ' '; " (*CLEAR EXTRA CHARS IN SEQ. FLD*)
END (*RESWORDS*) ;
PROCEDURE SYMBOLS;
BEGIN
RSY[1] := IFSY; RSY[2] := DOSY; RSY[3] := OFSY; RSY[4] := TOSY;
RSY[5] := RELOP; RSY[6] := ADDOP; RSY[7] := ENDSY; RSY[8] := FORSY;
RSY[9] := VARSY; RSY[10] := MULOP; RSY[11] := MULOP; RSY[12] := SETSY;
RSY[13] := MULOP; RSY[14] := NOTSY; RSY[15] := THENSY;
RSY[16] := ELSESY; RSY[17] := WITHSY; RSY[18] := GOTOSY;
RSY[19] := CASESY; RSY[20] := TYPESY; RSY[21] := FILESY;
RSY[22] := BEGINSY; RSY[23] := UNTILSY; RSY[24] := WHILESY;
RSY[25] := ARRAYSY; RSY[26] := CONSTSY; RSY[27] := LABELSY;
RSY[28] := REPEATSY; RSY[29] := RECORDSY; RSY[30] := DOWNTOSY;
RSY[31] := PACKEDSY; RSY[32] := FORWARDSY; RSY[33] := PROGSY;
RSY[34]:= FRTRNSY ; RSY[35] := EXTRNSY ;
RSY[36] := FUNCSY; RSY[37] := PROCSY;
SSY['+'] := ADDOP; SSY['-'] := ADDOP; SSY['*'] := MULOP;
SSY['/'] := MULOP; SSY['('] := LPARENT; SSY[')'] := RPARENT;
SSY['$'] := OTHERSY; SSY['='] := RELOP; SSY[' '] := OTHERSY;
SSY[','] := COMMA; SSY['.'] := PERIOD; SSY[''''] := OTHERSY;
SSY['!'] := LBRACK; SSY['?'] := RBRACK; SSY[':'] := COLON;
# SSY['['] := LBRACK; SSY[']'] := RBRACK; (*XSL10*)
# SSY['%'] := LBRACK;"SSY['|'] := ADDOP ;" SSY['&'] := MULOP ; (*XSL10*)
SSY['↑'] := ARROW; SSY['<'] := RELOP; SSY['>'] := RELOP;
# "SSY['¬'] := NOTSY ;" SSY[';'] := SEMICOLON; (*XSL10*)
END (*SYMBOLS*) ;
PROCEDURE RATORS;
VAR I: INTEGER; CH: CHAR;
BEGIN
FOR I := 1 TO NRSW (*NR OF RES WORDS*) DO ROP[I] := NOOP;
ROP[5] := INOP; ROP[10] := IDIV; ROP[11] := IMOD;
ROP[6] := OROP; ROP[13] := ANDOP;
# "FOR CH := '+' TO ';' DO SOP[CH] := NOOP;" (*XSL10*)
# FOR CH := ' ' TO '←' DO SOP[CH] := NOOP; (*XSL10*)
SOP['+'] := PLUS; SOP['-'] := MINUS; SOP['*'] := MUL; SOP['/'] := RDIV;
SOP['='] := EQOP;
SOP['<'] := LTOP; SOP['>'] := GTOP;
# "SOP['|'] := OROP ;" SOP['&'] := ANDOP ; (*XSL10*)
END (*RATORS*) ;
PROCEDURE PROCMNEMONICS;
BEGIN
# SNA[ 1] :='GET'; SNA[ 2] :='PUT'; SNA[ 3] :='RES'; SNA[ 4] :='REW';
SNA[ 5] :='RDC'; SNA[ 6] :='WRI'; SNA[ 7] :='WRO'; SNA[ 8] :='WRR';
SNA[ 9] :='WRC'; SNA[10] :='WRS'; SNA[11] :='PAK'; SNA[12] :='RDB';
# SNA[13] :='WRB'; SNA[14] :='RDR'; SNA[15] :='SIN'; SNA[16] :='COS';
SNA[17] :='EXP'; SNA[18] :='SQT'; SNA[19] :='LOG'; SNA[20] :='ATN';
# SNA[21] :='CLK'; SNA[22] :='WLN'; SNA[23] :='RLN'; SNA[24] :='RDI';
# SNA[25] :='EOF'; SNA[26] :='ELN'; SNA[27] :='RDS'; SNA[28] :='TRP';
# SNA[29] :='XIT'; SNA[30] :='EIO'; SNA[31] :='SIO';
END (*PROCMNEMONICS*) ;
(** INSTRMNEMONICS **)
PROCEDURE INSTRMNEMONICS;
BEGIN
MN[0] :=' ABI'; MN[1] :=' ABR'; MN[2] :=' ADI'; MN[3] :=' ADR';
MN[4] :=' AND'; MN[5] :=' DIF'; MN[6] :=' DVI'; MN[7] :=' DVR';
MN[8] :=' SBR'; MN[9] :=' FLO'; MN[10] :=' FLT'; MN[11] :=' INN';
MN[12] :=' INT'; MN[13] :=' IOR'; MN[14] :=' MOD'; MN[15] :=' MPI';
MN[16] :=' MPR'; MN[17] :=' NGI'; MN[18] :=' NGR'; MN[19] :=' NOT';
MN[20] :=' ODD'; MN[21] :=' SBI'; MN[22] :=' DEC'; MN[23] :=' INC';
MN[24] :=' SQI'; MN[25] :=' SQR'; MN[26] :=' STO'; MN[27] :=' TRC';
MN[28] :=' UNI'; MN[29] :=' SGS'; MN[30] :=' CSP'; MN[31] :=' ';
MN[32] :=' ENT'; MN[33] :=' FJP'; MN[34] :=' '; MN[35] :=' IND';
MN[36] :=' IXA'; MN[37] :=' LCA'; MN[38] :=' CTS'; MN[39] :=' CTI';
MN[40] :=' MOV'; MN[41] :=' MST'; MN[42] :=' RET'; MN[43] :=' STP';
MN[44] :=' XJP'; MN[45] :=' CHK'; MN[46] :=' CUP'; MN[47] :=' EQU';
MN[48] :=' GEQ'; MN[49] :=' GRT'; MN[50] :=' LDA'; MN[51] :=' LDC';
MN[52] :=' LEQ'; MN[53] :=' LES'; MN[54] :=' LOD'; MN[55] :=' NEQ';
# MN[56] :=' STR'; MN[57] :=' UJP'; MN[58] :=' NEW'; MN[59] :=' SAV';
# MN[60] :=' RST'; MN[61] :=' ORD'; MN[62] :=' CHR'; MN[63] :=' DEF';
"S1" MN[64] :=' PAR';
END (*INSTRMNEMONICS*) ;
BEGIN (*INITTABLES*)
RESWORDS; SYMBOLS; RATORS;
INSTRMNEMONICS; PROCMNEMONICS;
END (*INITTABLES*) ;
BEGIN (*PASCALCOMPILER*)
(*INITIALIZE*)
(************)
INITSCALARS; INITSETS; INITTABLES;
(*ENTER STANDARD NAMES AND STANDARD TYPES:*)
(******************************************)
LEVEL := 0; TOP := 0;
WITH DISPLAY[0] DO
BEGIN FNAME := NIL; FLABEL := NIL; OCCUR := BLCK END;
ENTERSTDTYPES; STDNAMES; ENTSTDNAMES; ENTERUNDECL;
TOP := 1; LEVEL := 1;
WITH DISPLAY[1] DO
BEGIN FNAME := NIL; FLABEL := NIL; OCCUR := BLCK END;
(*COMPILE:*)
(**********)
# WRITELN(OUTPUT, ' LINE # P/D LC LVL ',
# '< STANFORD PASCAL_P COMPILER, VERSION OF AUG.-78 >' ) ;
# WRITELN(OUTPUT) ;
# CTIME := CLOCK ; (*XSL10*) (*X10S1*)
(*# CTIME := CLOCK(1); *) (*XSL10*) (*X10S1*)
#
SKIP_E_DIRECTORY; (*XSL10*)
# INSYMBOL;
# PROGRAMME(BLOCKBEGSYS+STATBEGSYS-[CASESY]);
# CTIME := (CLOCK-CTIME) DIV 10; (*XSL10*) (*X10S1*)
(*# CTIME := (CLOCK(1)-CTIME) DIV 10; *) (*XSL10*) (*X10S1*)
# WRITELN(OUTPUT); WRITELN(OUTPUT);
# IF ERRORCOUNT = 0 THEN WRITE(OUTPUT,'**** NO':19)
# ELSE WRITE(OUTPUT,'****':14,ERRORCOUNT:5) ;
# WRITELN(OUTPUT, ' SYNTAX ERROR(S) DETECTED.') ; WRITELN(OUTPUT) ;
# WRITELN(OUTPUT, '****':14, LINECOUNT:6,' LINE(S) READ, ',PROCLAB:4,
# ' PROCEDURE(S) COMPILED,'); WRITELN() ;
# WRITELN('****':14, OLDIC:6,' P_INSTRUCTIONS GENERATED,',
# CTIME DIV 100 :4, '.', CTIME:2, ' SECONDS IN COMPILATION.') ;
#"EXIT(ERRORCOUNT);" (*XSL10*)
IF ERRORCOUNT <> 0 THEN (*XSL10*)
# ERREXIT(ERRORCOUNT) ; (*XSL10*)
END. (*PASCALCOMPILER*)